diff options
| -rw-r--r-- | GNUmakefile | 25 | ||||
| -rw-r--r-- | MLKBackquoteReader.h | 27 | ||||
| -rw-r--r-- | MLKBackquoteReader.m | 62 | ||||
| -rw-r--r-- | MLKCommaReader.h | 27 | ||||
| -rw-r--r-- | MLKCommaReader.m | 73 | ||||
| -rw-r--r-- | MLKCons.m | 16 | ||||
| -rw-r--r-- | MLKDynamicContext.m | 12 | ||||
| -rw-r--r-- | MLKInterpreter.h | 5 | ||||
| -rw-r--r-- | MLKInterpreter.m | 364 | ||||
| -rw-r--r-- | MLKPackage.m | 4 | ||||
| -rw-r--r-- | MLKParenReader.m | 34 | ||||
| -rw-r--r-- | MLKReader.h | 7 | ||||
| -rw-r--r-- | MLKReader.m | 25 | ||||
| -rw-r--r-- | MLKRoot.m | 29 | ||||
| -rw-r--r-- | cond.lisp | 29 | ||||
| -rw-r--r-- | destructuring-bind.lisp | 114 | ||||
| -rw-r--r-- | init.lisp | 2 | ||||
| -rw-r--r-- | util.lisp | 195 |
18 files changed, 940 insertions, 110 deletions
diff --git a/GNUmakefile b/GNUmakefile index 4af0e66..22398e9 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -27,18 +27,19 @@ BUNDLE_NAME = Test ADDITIONAL_OBJCFLAGS = -Wall -ToiletKit_OBJC_FILES = MLKCharacter.m MLKCons.m MLKBinding.m \ - MLKDoubleFloat.m MLKDynamicContext.m \ - MLKEnvironment.m MLKFloat.m MLKInteger.m \ - MLKInterpretedClosure.m MLKInterpreter.m \ - MLKLinkedList.m MLKLexicalContext.m \ - MLKLexicalEnvironment.m MLKLispValue.m \ - MLKNumber.m MLKPackage.m MLKParenReader.m \ - MLKQuoteReader.m MLKRatio.m MLKReader.m \ - MLKReadtable.m MLKReaderError.m MLKRoot.m \ - MLKSemicolonReader.m MLKSingleFloat.m MLKStream.m \ - MLKStringInputStream.m MLKStringOutputStream.m \ - MLKStringReader.m MLKSymbol.m MLKThrowException.m \ +ToiletKit_OBJC_FILES = MLKCharacter.m MLKCons.m MLKBackquoteReader.m \ + MLKBinding.m MLKCommaReader.m MLKDoubleFloat.m \ + MLKDynamicContext.m MLKEnvironment.m MLKFloat.m \ + MLKInteger.m MLKInterpretedClosure.m \ + MLKInterpreter.m MLKLinkedList.m \ + MLKLexicalContext.m MLKLexicalEnvironment.m \ + MLKLispValue.m MLKNumber.m MLKPackage.m \ + MLKParenReader.m MLKQuoteReader.m MLKRatio.m \ + MLKReader.m MLKReadtable.m MLKReaderError.m \ + MLKRoot.m MLKSemicolonReader.m MLKSingleFloat.m \ + MLKStream.m MLKStringInputStream.m \ + MLKStringOutputStream.m MLKStringReader.m \ + MLKSymbol.m MLKThrowException.m \ NSObject-MLKPrinting.m NSString-MLKPrinting.m ToiletKit_LDFLAGS = -lgmp #LIBRARIES_DEPEND_UPON diff --git a/MLKBackquoteReader.h b/MLKBackquoteReader.h new file mode 100644 index 0000000..1c35bfa --- /dev/null +++ b/MLKBackquoteReader.h @@ -0,0 +1,27 @@ +/* -*- mode: objc; coding: utf-8 -*- */ +/* Étoilisp/Mulklisp, a Common Lisp subset for the Étoilé runtime. + * Copyright (C) 2008 Matthias Andreas Benkard. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <http://www.gnu.org/licenses/>. + */ + +#import "MLKFuncallable.h" +#import "MLKLispValue.h" + +#import <Foundation/NSArray.h> + + +@interface MLKBackquoteReader : MLKLispValue <MLKFuncallable> +-(NSArray *) applyToArray:(NSArray *)arguments; +@end diff --git a/MLKBackquoteReader.m b/MLKBackquoteReader.m new file mode 100644 index 0000000..47989ab --- /dev/null +++ b/MLKBackquoteReader.m @@ -0,0 +1,62 @@ +/* -*- mode: objc; coding: utf-8 -*- */ +/* Étoilisp/Mulklisp, a Common Lisp subset for the Étoilé runtime. + * Copyright (C) 2008 Matthias Andreas Benkard. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <http://www.gnu.org/licenses/>. + */ + +#import "MLKBackquoteReader.h" + +#import "MLKCons.h" +#import "MLKDynamicContext.h" +#import "MLKReader.h" +#import "MLKReadtable.h" +#import "MLKPackage.h" +#import "MLKStream.h" +#import "runtime-compatibility.h" +#import "util.h" + + +@implementation MLKBackquoteReader +-(NSArray *) applyToArray:(NSArray *)arguments +{ + MLKStream *stream; + MLKReadtable *readtable; + MLKPackage *cl, *sys; + unichar ch; + id quoted_form; + + cl = [MLKPackage findPackage:@"COMMON-LISP"]; + sys = [MLKPackage findPackage:@"TOILET-SYSTEM"]; + + stream = [arguments objectAtIndex:0]; + readtable = [[MLKDynamicContext currentContext] + valueForSymbol:[cl intern:@"*READTABLE*"]]; + + while ([readtable isWhitespaceCharacter:(ch = [stream readChar])]); + + [stream unreadChar:ch]; + + quoted_form = [MLKReader readFromStream:stream + eofError:YES + eofValue:nil + recursive:YES + preserveWhitespace:NO]; + + return [NSArray arrayWithObject: + [MLKCons cons:[sys intern:@"QUASIQUOTE"] + with:[MLKCons cons:nullify(quoted_form) + with:nil]]]; +} +@end diff --git a/MLKCommaReader.h b/MLKCommaReader.h new file mode 100644 index 0000000..5f5d11e --- /dev/null +++ b/MLKCommaReader.h @@ -0,0 +1,27 @@ +/* -*- mode: objc; coding: utf-8 -*- */ +/* Étoilisp/Mulklisp, a Common Lisp subset for the Étoilé runtime. + * Copyright (C) 2008 Matthias Andreas Benkard. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <http://www.gnu.org/licenses/>. + */ + +#import "MLKFuncallable.h" +#import "MLKLispValue.h" + +#import <Foundation/NSArray.h> + + +@interface MLKCommaReader : MLKLispValue <MLKFuncallable> +-(NSArray *) applyToArray:(NSArray *)arguments; +@end diff --git a/MLKCommaReader.m b/MLKCommaReader.m new file mode 100644 index 0000000..3a0115b --- /dev/null +++ b/MLKCommaReader.m @@ -0,0 +1,73 @@ +/* -*- mode: objc; coding: utf-8 -*- */ +/* Étoilisp/Mulklisp, a Common Lisp subset for the Étoilé runtime. + * Copyright (C) 2008 Matthias Andreas Benkard. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see <http://www.gnu.org/licenses/>. + */ + +#import "MLKCommaReader.h" + +#import "MLKCons.h" +#import "MLKDynamicContext.h" +#import "MLKReader.h" +#import "MLKReadtable.h" +#import "MLKPackage.h" +#import "MLKStream.h" +#import "runtime-compatibility.h" +#import "util.h" + + +@implementation MLKCommaReader +-(NSArray *) applyToArray:(NSArray *)arguments +{ + MLKStream *stream; + MLKReadtable *readtable; + MLKPackage *cl, *sys; + MLKSymbol *marker; + unichar ch; + id quoted_form; + + cl = [MLKPackage findPackage:@"COMMON-LISP"]; + sys = [MLKPackage findPackage:@"TOILET-SYSTEM"]; + + stream = [arguments objectAtIndex:0]; + readtable = [[MLKDynamicContext currentContext] + valueForSymbol:[cl intern:@"*READTABLE*"]]; + + if ((ch = [stream readChar]) == '@') + { + marker = [sys intern:@"UNQUOTE-SPLICING"]; + } + else + { + marker = [sys intern:@"UNQUOTE"]; + [stream unreadChar:ch]; + } + + while ([readtable isWhitespaceCharacter:(ch = [stream readChar])]); + + [stream unreadChar:ch]; + + quoted_form = [MLKReader readFromStream:stream + eofError:YES + eofValue:nil + recursive:YES + preserveWhitespace:NO]; + + return [NSArray arrayWithObject: + [MLKCons cons:marker + with:[MLKCons cons:nullify(quoted_form) + with:nil]]]; +} +@end @@ -113,10 +113,18 @@ -(NSString *)descriptionForLisp { - if ([_cdr isKindOfClass:[MLKCons class]] - && _car == [[MLKPackage findPackage:@"COMMON-LISP"] intern:@"QUOTE"]) - return [NSString stringWithFormat:@"'%@", [_cdr bareDescriptionForLisp]]; - else + if ([_cdr isKindOfClass:[MLKCons class]]) + { + if (_car == [[MLKPackage findPackage:@"COMMON-LISP"] intern:@"QUOTE"]) + return [NSString stringWithFormat:@"'%@", [_cdr bareDescriptionForLisp]]; + else if (_car == [[MLKPackage findPackage:@"TOILET-SYSTEM"] intern:@"QUASIQUOTE"]) + return [NSString stringWithFormat:@"`%@", [_cdr bareDescriptionForLisp]]; + else if (_car == [[MLKPackage findPackage:@"TOILET-SYSTEM"] intern:@"UNQUOTE"]) + return [NSString stringWithFormat:@",%@", [_cdr bareDescriptionForLisp]]; + else if (_car == [[MLKPackage findPackage:@"TOILET-SYSTEM"] intern:@"UNQUOTE-SPLICING"]) + return [NSString stringWithFormat:@",@%@", [_cdr bareDescriptionForLisp]]; + } + return [NSString stringWithFormat:@"(%@)", [self bareDescriptionForLisp]]; } diff --git a/MLKDynamicContext.m b/MLKDynamicContext.m index 593f4a7..1b8725b 100644 --- a/MLKDynamicContext.m +++ b/MLKDynamicContext.m @@ -24,6 +24,8 @@ #import <Foundation/NSString.h> #import <Foundation/NSThread.h> +#import "MLKBackquoteReader.h" +#import "MLKCommaReader.h" #import "MLKCons.h" #import "MLKDynamicContext.h" #import "MLKEnvironment.h" @@ -147,8 +149,6 @@ static MLKDynamicContext *global_context; [readtable setSyntaxType:MULTI_ESCAPE forCharacter:'|']; // [readtable setSyntaxType:NONTERMINATING_MACRO forCharacter:'#']; - // [readtable setSyntaxType:TERMINATING_MACRO forCharacter:'`']; - // [readtable setSyntaxType:TERMINATING_MACRO forCharacter:',']; [readtable setSyntaxType:SINGLE_ESCAPE forCharacter:'\\']; @@ -164,6 +164,14 @@ static MLKDynamicContext *global_context; [readtable setSyntaxType:TERMINATING_MACRO forCharacter:'\'']; [readtable setMacroFunction:AUTORELEASE([[MLKQuoteReader alloc] init]) forCharacter:'\'']; + + [readtable setSyntaxType:TERMINATING_MACRO forCharacter:'`']; + [readtable setMacroFunction:AUTORELEASE([[MLKBackquoteReader alloc] init]) + forCharacter:'`']; + + [readtable setSyntaxType:TERMINATING_MACRO forCharacter:',']; + [readtable setMacroFunction:AUTORELEASE([[MLKCommaReader alloc] init]) + forCharacter:',']; [readtable setSyntaxType:TERMINATING_MACRO forCharacter:';']; [readtable setMacroFunction:AUTORELEASE([[MLKSemicolonReader alloc] init]) diff --git a/MLKInterpreter.h b/MLKInterpreter.h index 788dfe1..8ff119f 100644 --- a/MLKInterpreter.h +++ b/MLKInterpreter.h @@ -31,5 +31,10 @@ inLexicalContext:(MLKLexicalContext *)context withEnvironment:(MLKLexicalEnvironment *)lexenv; ++(NSArray*) eval:(id)program + inLexicalContext:(MLKLexicalContext *)context + withEnvironment:(MLKLexicalEnvironment *)lexenv + expandOnly:(BOOL)expandOnly; + +(BOOL) load:(MLKStream *)stream verbose:(BOOL)verbose print:(BOOL)print; @end diff --git a/MLKInterpreter.m b/MLKInterpreter.m index c2d7ba4..3d55f33 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -102,9 +102,25 @@ static MLKSymbol *_LAMBDA; inLexicalContext:(MLKLexicalContext *)context withEnvironment:(MLKLexicalEnvironment *)lexenv { + return (NSArray *)[self eval:program + inLexicalContext:context + withEnvironment:lexenv + expandOnly:NO]; +} + + +#define RETURN_VALUE(thing) \ + { return [NSArray arrayWithObject:nullify(thing)]; } + + ++(NSArray*) eval:(id)program + inLexicalContext:(MLKLexicalContext *)context + withEnvironment:(MLKLexicalEnvironment *)lexenv + expandOnly:(BOOL)expandOnly +{ MLKDynamicContext *dynamicContext = [MLKDynamicContext currentContext]; - //NSLog (@"eval: %@", [program descriptionForLisp]); + // NSLog (@"eval: %@", [program descriptionForLisp]); if (!program || [program isKindOfClass:[MLKSymbol class]]) { @@ -117,27 +133,34 @@ static MLKSymbol *_LAMBDA; program, context, nil]]; return [self eval:expansion inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; } else if ([context variableIsLexical:program]) { //NSLog (@"Processing lexical variable %@.", [program descriptionForLisp]); //NSLog (@"Lexical environment: %@.", lexenv); //NSLog (@"Lexical variable value: %@.", [lexenv valueForSymbol:program]); - return [NSArray arrayWithObject:nullify([lexenv valueForSymbol:program])]; + if (expandOnly) + RETURN_VALUE (program); + + RETURN_VALUE ([lexenv valueForSymbol:program]); } else { //NSLog (@"Processing special variable %@.", [program descriptionForLisp]); //NSLog (@"Dynamic context: %@.", dynamicContext); //NSLog (@"Special variable value: %@.", [dynamicContext valueForSymbol:program]); - return [NSArray arrayWithObject:nullify([dynamicContext valueForSymbol:program])]; + if (expandOnly) + RETURN_VALUE (program); + + RETURN_VALUE ([dynamicContext valueForSymbol:program]); } } else if (![program isKindOfClass:[MLKCons class]]) { // Everything that is not a list or a symbol evaluates to itself. - return [NSArray arrayWithObject:nullify(program)]; + RETURN_VALUE (program); } else { @@ -149,14 +172,22 @@ static MLKSymbol *_LAMBDA; { MLKCons *rest = denullify([[self eval:[[[program cdr] cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]); id function = denullify([[self eval:[[program cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]); + if (expandOnly) + RETURN_VALUE ([MLKCons cons:APPLY + with:[MLKCons cons:function + with:[MLKCons cons:rest + with:nil]]]); + if ([function isKindOfClass:[MLKSymbol class]]) function = [lexenv functionForSymbol:function]; @@ -174,21 +205,33 @@ static MLKSymbol *_LAMBDA; { catchTag = [[self eval:[[program cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; - - newctx = [[MLKDynamicContext alloc] - initWithParent:dynamicContext - variables:nil - handlers:nil - restarts:nil - catchTags:[NSSet setWithObject:catchTag] - activeHandlerEnvironment:nil]; - [newctx pushContext]; + + if (!expandOnly) + { + newctx = [[MLKDynamicContext alloc] + initWithParent:dynamicContext + variables:nil + handlers:nil + restarts:nil + catchTags:[NSSet setWithObject:catchTag] + activeHandlerEnvironment:nil]; + [newctx pushContext]; + } values = [self eval:[MLKCons cons:PROGN with:[[program cdr] cdr]] inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; + + if (expandOnly) + NS_VALUERETURN ([NSArray arrayWithObject: + [MLKCons cons:CATCH + with:[MLKCons cons:catchTag + with:values]]], + NSArray *); [MLKDynamicContext popContext]; RELEASE (newctx); @@ -227,21 +270,49 @@ static MLKSymbol *_LAMBDA; id <MLKFuncallable> function; + if (expandOnly) + { + id lambdaList = [lambdaListAndBody car]; + id body = [lambdaListAndBody cdr]; + id body_expansion = + denullify([[self eval:[MLKCons cons:PROGN with:body] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + RETURN_VALUE ([MLKCons + cons:_DEFMACRO + with:[MLKCons + cons:name + with:[MLKCons + cons:lambdaList + with:[MLKCons + cons:body_expansion + with:nil]]]]); + } + function = denullify([[self eval:[MLKCons cons:_LAMBDA with:lambdaListAndBody] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]); [context addMacro:function forSymbol:name]; - return [NSArray arrayWithObject:nullify(name)]; + RETURN_VALUE (name); } else if (car == EVAL) { - return [self eval:denullify([[self eval:[program cdr] - inLexicalContext:context - withEnvironment:lexenv] - objectAtIndex:0]) + NSArray *evaluand = denullify([[self eval:[program cdr] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + + if (expandOnly) + RETURN_VALUE ([MLKCons cons:EVAL with:[MLKCons cons:evaluand with:nil]]); + + return [self eval:evaluand inLexicalContext:[MLKLexicalContext globalContext] withEnvironment:[MLKLexicalEnvironment globalEnvironment]]; @@ -253,20 +324,50 @@ static MLKSymbol *_LAMBDA; // Incidentally works for the two-clause case: id alternative = [[[[program cdr] cdr] cdr] car]; - NSArray *values = [self eval:condition - inLexicalContext:context - withEnvironment:lexenv]; - if ([values objectAtIndex:0] == [NSNull null]) + id condition_value = denullify([[self eval:condition + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + + if (expandOnly) + { + id conseq_expansion = denullify([[self eval:consequent + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + id alt_expansion = denullify([[self eval:alternative + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + RETURN_VALUE ([MLKCons + cons:IF + with:[MLKCons + cons:condition_value + with:[MLKCons + cons:conseq_expansion + with:[MLKCons cons:alt_expansion + with:nil]]]]); + } + + if (!condition_value) return [self eval:alternative inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; else return [self eval:consequent inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; } else if (car == IN_PACKAGE) { + if (expandOnly) + RETURN_VALUE (program); + id cadr = [[program cdr] car]; id package = [MLKPackage findPackage:stringify(cadr)]; @@ -275,7 +376,7 @@ static MLKSymbol *_LAMBDA; forSymbol:[[MLKPackage findPackage:@"COMMON-LISP"] intern:@"*PACKAGE*"]]; - return [NSArray arrayWithObject:nullify(package)]; + RETURN_VALUE (package); } else if (car == _LAMBDA) { @@ -286,6 +387,21 @@ static MLKSymbol *_LAMBDA; id body = [[program cdr] cdr]; MLKInterpretedClosure *closure; + if (expandOnly) + { + id body_expansion = denullify([[self eval:[MLKCons cons:PROGN + with:body] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + RETURN_VALUE ([MLKCons + cons:_LAMBDA + with:[MLKCons cons:lambdaList + with:[MLKCons cons:body_expansion + with:nil]]]); + } + closure = AUTORELEASE ([[MLKInterpretedClosure alloc] initWithBodyForms:body lambdaListName:lambdaList @@ -315,6 +431,24 @@ static MLKSymbol *_LAMBDA; declarations = nil; } + if (expandOnly) + { + id body_expansion = denullify([[self eval:[MLKCons cons:PROGN + with:body] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0]); + RETURN_VALUE ([MLKCons + cons:LET + with:[MLKCons + cons:[[program cdr] car] + with:[MLKCons + cons:declarations + with:[MLKCons cons:body_expansion + with:nil]]]]); + } + env = AUTORELEASE ([[MLKLexicalEnvironment alloc] initWithParent:lexenv variables:nil @@ -400,34 +534,47 @@ static MLKSymbol *_LAMBDA; { id result = nil; id rest = program; + NSMutableArray *results = [NSMutableArray array]; while ((rest = [rest cdr])) { result = [self eval:[rest car] inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; + if (expandOnly) + [results addObjectsFromArray:result]; } - return result; + if (expandOnly) + { + RETURN_VALUE ([MLKCons cons:PROGN + with:[MLKCons listWithArray:results]]); + } + else + return result; } else if (car == QUOTE) { - return [NSArray arrayWithObject:nullify([[program cdr] car])]; + if (expandOnly) + RETURN_VALUE (program); + RETURN_VALUE ([[program cdr] car]); } else if (car == SETQ) { id symbol = [[program cdr] car]; id value = [[self eval:[[[program cdr] cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; id rest = [[[program cdr] cdr] cdr]; if (![program cdr]) - return [NSArray arrayWithObject:[NSNull null]]; + RETURN_VALUE (nil); if ([context symbolNamesSymbolMacro:symbol]) { - id macrofun = [context macroForSymbol:program]; + id macrofun = [context symbolMacroForSymbol:symbol]; id expansion = [macrofun applyToArray: [NSArray arrayWithObjects: program, context, nil]]; @@ -438,7 +585,25 @@ static MLKSymbol *_LAMBDA; with: [[program cdr] cdr]]] inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; + } + + if (expandOnly) + { + RETURN_VALUE ([MLKCons + cons:SETQ + with:[MLKCons + cons:symbol + with:[MLKCons + cons:value + with:denullify([[self eval: + [MLKCons cons:SETQ + with:rest] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly] + objectAtIndex:0])]]]); } if ([context variableIsLexical:symbol]) @@ -456,19 +621,27 @@ static MLKSymbol *_LAMBDA; inLexicalContext:context withEnvironment:lexenv]; else - return [NSArray arrayWithObject:value]; + RETURN_VALUE (value); } else if (car == SET) { id symbol = [[self eval:[[program cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; id value = [[self eval:[[[program cdr] cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; + if (expandOnly) + RETURN_VALUE ([MLKCons cons:SET + with:[MLKCons cons:symbol + with:[MLKCons cons:value + with:nil]]]); + if ([dynamicContext bindingForSymbol:symbol]) [dynamicContext setValue:value forSymbol:symbol]; else @@ -482,13 +655,21 @@ static MLKSymbol *_LAMBDA; // Like SET, but for the function cell. id symbol = [[self eval:[[program cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; id value = [[self eval:[[[program cdr] cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; + if (expandOnly) + RETURN_VALUE ([MLKCons cons:_FSET + with:[MLKCons cons:symbol + with:[MLKCons cons:value + with:nil]]]); + [[MLKLexicalContext globalContext] addFunction:symbol]; [[MLKLexicalEnvironment globalEnvironment] addFunction:value forSymbol:symbol]; @@ -507,12 +688,20 @@ static MLKSymbol *_LAMBDA; catchTag = [[self eval:[[program cdr] car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; values = [self eval:[[[program cdr] cdr] car] inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; + + if (expandOnly) + RETURN_VALUE ([MLKCons cons:THROW + with:[MLKCons cons:denullify(catchTag) + with:[MLKCons cons:denullify([values objectAtIndex:0]) + with:nil]]]); userInfo = [NSDictionary dictionaryWithObjectsAndKeys: catchTag, @"THROWN TAG", @@ -541,6 +730,23 @@ static MLKSymbol *_LAMBDA; { NSArray *results; + if (expandOnly) + { + id protectee = [self eval:[[program cdr] car] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly]; + id protection = [self eval:[MLKCons cons:PROGN + with:[[program cdr] cdr]] + inLexicalContext:context + withEnvironment:lexenv + expandOnly:expandOnly]; + RETURN_VALUE ([MLKCons cons:UNWIND_PROTECT + with:[MLKCons cons:protectee + with:[MLKCons cons:protection + with:nil]]]); + } + NS_DURING { results = [self eval:[[program cdr] car] @@ -551,7 +757,8 @@ static MLKSymbol *_LAMBDA; { [self eval:[MLKCons cons:PROGN with:[[program cdr] cdr]] inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; [localException raise]; } @@ -573,17 +780,21 @@ static MLKSymbol *_LAMBDA; [results addObject: [[self eval:[rest car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]]; } + if (expandOnly) + RETURN_VALUE ([MLKCons cons:VALUES + with:[MLKCons listWithArray:results]]); return results; } else { if ([context symbolNamesFunction:car]) { - id function = [lexenv functionForSymbol:car]; + id function; MLKCons *rest = [program cdr]; NSMutableArray *args = [NSMutableArray array]; @@ -591,13 +802,23 @@ static MLKSymbol *_LAMBDA; { id result = [[self eval:[rest car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; [args addObject:result]; rest = [rest cdr]; } - - return [function applyToArray:args]; + + if (expandOnly) + { + RETURN_VALUE ([MLKCons cons:[program car] + with:[MLKCons listWithArray:args]]); + } + else + { + function = [lexenv functionForSymbol:car]; + return [function applyToArray:args]; + } } else if ([context symbolNamesMacro:car]) { @@ -610,7 +831,8 @@ static MLKSymbol *_LAMBDA; return [self eval:expansion inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; } else { @@ -622,12 +844,19 @@ static MLKSymbol *_LAMBDA; { id result = [[self eval:[rest car] inLexicalContext:context - withEnvironment:lexenv] + withEnvironment:lexenv + expandOnly:expandOnly] objectAtIndex:0]; [args addObject:result]; rest = [rest cdr]; } + if (expandOnly) + { + RETURN_VALUE ([MLKCons cons:[program car] + with:[MLKCons listWithArray:args]]); + } + results = [MLKRoot dispatch:car withArguments:args]; if (results) @@ -648,7 +877,8 @@ static MLKSymbol *_LAMBDA; { return [self eval:[MLKCons cons:FUNCALL with:program] inLexicalContext:context - withEnvironment:lexenv]; + withEnvironment:lexenv + expandOnly:expandOnly]; } else { @@ -668,6 +898,7 @@ static MLKSymbol *_LAMBDA; while (YES) { id result; + id expansion; //NSLog (@"; LOAD: Reding a form."); id code = [MLKReader readFromStream:stream eofError:NO @@ -692,12 +923,29 @@ static MLKSymbol *_LAMBDA; else formdesc = [code descriptionForLisp]; - fprintf (stderr, "; LOAD: %s\n", - [formdesc UTF8String]); + fprintf (stderr, "; COMPILE-MINIMALLY: %s\n", [formdesc UTF8String]); + expansion = denullify([[MLKInterpreter + eval:code + inLexicalContext:[MLKLexicalContext + globalContext] + withEnvironment:[MLKLexicalEnvironment + globalEnvironment] + expandOnly:YES] + objectAtIndex:0]); + + if ([code isKindOfClass:[MLKCons class]] && [code cdr]) + formdesc = [NSString stringWithFormat:@"(%@ %@ ...)", + [[expansion car] descriptionForLisp], + [[[expansion cdr] car] descriptionForLisp]]; + else + formdesc = [expansion descriptionForLisp]; + + fprintf (stderr, "; LOAD: %s\n", [formdesc UTF8String]); result = [MLKInterpreter - eval:code + eval:expansion inLexicalContext:[MLKLexicalContext globalContext] - withEnvironment:[MLKLexicalEnvironment globalEnvironment]]; + withEnvironment:[MLKLexicalEnvironment globalEnvironment] + expandOnly:NO]; //NSLog (@"; LOAD: Top-level form evaluated."); if (print) diff --git a/MLKPackage.m b/MLKPackage.m index cae3416..039596a 100644 --- a/MLKPackage.m +++ b/MLKPackage.m @@ -115,6 +115,10 @@ static NSMutableDictionary *packages = nil; [sys export:[sys intern:@"MAKE-SYMBOL"]]; [sys export:[sys intern:@"IMPORT"]]; [sys export:[sys intern:@"INTERN"]]; + [sys export:[sys intern:@"OBJC-CLASS-OF"]]; + [sys export:[sys intern:@"OBJC-SUBCLASSP"]]; + [sys export:[sys intern:@"FIND-OBJC-CLASS"]]; + [sys export:[sys intern:@"NS-LOG"]]; [cl export:[cl intern:@"*BREAK-ON-SIGNALS*"]]; [cl export:[cl intern:@"*COMPILE-FILE-PATHNAME*"]]; diff --git a/MLKParenReader.m b/MLKParenReader.m index 9287ce9..b61a332 100644 --- a/MLKParenReader.m +++ b/MLKParenReader.m @@ -59,6 +59,7 @@ static unichar slurpWhitespaceAndPeek (MLKStream *stream, MLKReadtable *readtabl while ((nextChar = slurpWhitespaceAndPeek(stream, readtable)) != ')') { id item; + id dotMarker = [[NSObject alloc] init]; // FIXME: What to do about dots? Maybe add a new // singleDotAllowed:(BOOL)dotp argument to readFromStream:...? @@ -66,8 +67,35 @@ static unichar slurpWhitespaceAndPeek (MLKStream *stream, MLKReadtable *readtabl eofError:YES eofValue:nil recursive:YES - preserveWhitespace:NO]; - + preserveWhitespace:NO + singleDotMarker:dotMarker]; + + if (item == dotMarker) + { + id nextItem; + + RELEASE (dotMarker); + + nextItem = [MLKReader readFromStream:stream + eofError:YES + eofValue:nil + recursive:YES + preserveWhitespace:NO + singleDotMarker:nil]; + [tail setCdr:nextItem]; + + if ((nextChar = slurpWhitespaceAndPeek (stream, readtable)) == ')') + { + [stream readChar]; + return [NSArray arrayWithObject:cons]; + } + else + { + [NSException raise:@"MLKReaderError" + format:@"Unexpectedly read a single dot."]; + } + } + if (!tail) { cons = tail = [MLKCons cons:item with:nil]; @@ -77,6 +105,8 @@ static unichar slurpWhitespaceAndPeek (MLKStream *stream, MLKReadtable *readtabl [tail setCdr:[MLKCons cons:item with:nil]]; tail = [tail cdr]; } + + RELEASE (dotMarker); } [stream readChar]; diff --git a/MLKReader.h b/MLKReader.h index 9a49ef9..60954f1 100644 --- a/MLKReader.h +++ b/MLKReader.h @@ -26,6 +26,13 @@ eofError:(BOOL)eofError eofValue:(id)eofValue recursive:(BOOL)recursive + preserveWhitespace:(BOOL)preserveWhitespace + singleDotMarker:(id)dotMarker; + ++(id) readFromStream:(MLKStream *)stream + eofError:(BOOL)eofError + eofValue:(id)eofValue + recursive:(BOOL)recursive preserveWhitespace:(BOOL)preserveWhitespace; +(id) readFromString:(NSString *)string; diff --git a/MLKReader.m b/MLKReader.m index 7343c64..7db9670 100644 --- a/MLKReader.m +++ b/MLKReader.m @@ -45,6 +45,21 @@ recursive:(BOOL)recursive preserveWhitespace:(BOOL)preserveWhitespace { + return [self readFromStream:stream + eofError:eofError + eofValue:eofValue + recursive:recursive + preserveWhitespace:preserveWhitespace + singleDotMarker:nil]; +} + ++(id) readFromStream:(MLKStream *)stream + eofError:(BOOL)eofError + eofValue:(id)eofValue + recursive:(BOOL)recursive + preserveWhitespace:(BOOL)preserveWhitespace + singleDotMarker:(id)dotMarker +{ unichar ch; NSMutableString *token; MLKReadtable *readtable; @@ -169,6 +184,16 @@ } //NSLog (@"--> Interpret token: %@", token); + + if ([token isEqualToString:@"."]) + { + if (dotMarker) + return dotMarker; + else + [NSException raise:@"MLKReaderError" + format:@"Unexpectedly read a single dot."]; + } + return [self interpretToken:token readtable:readtable escaped:ever_escaped]; @@ -225,10 +225,12 @@ static id truify (BOOL value) +(NSArray *) macroexpand_1:(NSArray *)args { id form = [args objectAtIndex:0]; - id env = [args count] > 1 ? [args objectAtIndex:1] : nil; + id env = [args count] > 1 ? denullify([args objectAtIndex:1]) : nil; MLKLexicalContext *context = env ? (id)env : (id)[MLKLexicalContext globalContext]; - if ([context symbolNamesMacro:[form car]]) + if ([form isKindOfClass:[MLKCons class]] + && (![form car] || [[form car] isKindOfClass:[MLKSymbol class]]) + && [context symbolNamesMacro:[form car]]) { id <MLKFuncallable> macrofun = [context macroForSymbol:[form car]]; form = denullify ([[macrofun applyToArray: @@ -409,4 +411,27 @@ static id truify (BOOL value) RETURN_VALUE ([cl intern:@"T"]); } + ++(NSArray *) objc_class_of:(NSArray *)args +{ + RETURN_VALUE ([[args objectAtIndex:0] class]); +} + ++(NSArray *) objc_subclassp:(NSArray *)args +{ + RETURN_VALUE (truify ([[args objectAtIndex:0] isSubclassOfClass: + [args objectAtIndex:1]])); +} + ++(NSArray *) find_objc_class:(NSArray *)args +{ + RETURN_VALUE (NSClassFromString ([args objectAtIndex:0])); +} + ++(NSArray *) ns_log:(NSArray *)args +{ + NSString *description = [[args objectAtIndex:0] descriptionForLisp]; + NSLog (@"%@", description); + RETURN_VALUE ([args objectAtIndex:0]); +} @end diff --git a/cond.lisp b/cond.lisp deleted file mode 100644 index 7b3d1cc..0000000 --- a/cond.lisp +++ /dev/null @@ -1,29 +0,0 @@ -(%defun list* args - (if (null (cdr args)) - (car args) - (cons (car args) - (apply 'list* (cdr args))))) - -(%defmacro let* args - (let ((form (car args))) - (let ((bindings (car (cdr form))) - (body (cdr (cdr form)))) - (if (null bindings) - (list* 'let nil body) - (let ((first-binding (car bindings)) - (rest (cdr bindings))) - (list 'let - (list first-binding) - (list* 'let* rest body))))))) - -(%defmacro cond args - (let* ((form (car args)) - (clauses (cdr form)) - (clause (car clauses)) - (rest (cdr clauses))) - (if (null clauses) - nil - (list 'if - (car clause) - (cons 'progn (cdr clause)) - (cons 'cond rest))))) diff --git a/destructuring-bind.lisp b/destructuring-bind.lisp new file mode 100644 index 0000000..161390d --- /dev/null +++ b/destructuring-bind.lisp @@ -0,0 +1,114 @@ +(setq lambda-list-keywords + '(&allow-other-keys &aux &body &environment &key &optional &rest &whole)) + +(%defmacro* d-b (lambda-list environment whole-sym expression . body) + ;; (ns-log lambda-list) + `(let* ,(unless whole-sym + (let ((real-expression expression)) + (setq whole-sym (gensym "WHOLE") + expression (gensym "EXPRESSION")) + `((,expression ,real-expression) + (,whole-sym ,expression)))) + ,(cond ((consp lambda-list) + (case (car lambda-list) + (&environment + `(let ((,(cadr lambda-list) ,environment)) + (d-b ,(cddr lambda-list) ,environment ,whole-sym ,expression + ,@body))) + (&aux + (if (or (endp (cdr lambda-list)) + (member (cadr lambda-list) lambda-list-keywords)) + `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression + ,@body) + `(let (,(cadr lambda-list)) + (d-b (&aux ,@(cddr lambda-list)) ,environment ,whole-sym ,expression + ,@body)))) + (&optional + (if (or (endp (cdr lambda-list)) + (member (cadr lambda-list) lambda-list-keywords)) + `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression + ,@body) + (let ((sym (gensym)) + (head (car lambda-list))) + `(let* ((,sym ,expression) + ,@(cond ((atom head) + `((,head (cadr ,sym)))) + ((null (cdr head)) + `((,(car head) (cadr ,sym)))) + ((null (cddr head)) + `((,(car head) (if (null ,sym) + ,(cadr head) + (cadr ,sym))))) + (t + `((,(car head) (if (null ,sym) + ,(cadr head) + (cadr ,sym))) + (,(caddr head) (not (null ,sym))))))) + (d-b (&optional ,@(cddr lambda-list)) ,environment ,whole-sym (cdr ,sym) + ,@body))))) + ((&rest &body) + (if (member (cadr lambda-list) lambda-list-keywords) + `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression + ,@body) + (let ((sym (gensym))) + `(let* ((,sym ,expression) + (,(cadr lambda-list) ,sym)) + (d-b ,(cddr lambda-list) ,environment ,whole-sym ,sym + ,@body))))) + (&whole + `(let ((,(cadr lambda-list) ,whole-sym)) + (d-b ,(cddr lambda-list) ,environment ,whole-sym ,expression + ,@body))) + (&allow-other-keys + `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression + ,@body)) + (&key + (if (or (endp (cdr lambda-list)) + (member (cadr lambda-list) lambda-list-keywords)) + `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression + ,@body) + (let* ((sym (gensym)) + (value-sym (gensym)) + (missing (gensym "MISSING")) + (head (cadr lambda-list)) + (var (if (consp head) + (if (consp (car head)) + (cadar head) + (car head)) + head)) + (keyword-name + (if (and (consp head) (consp (car head))) + (caar head) + (intern (symbol-name var) '#:keyword)))) + `(let* ((,sym ,expression) + (,value-sym (getf ,sym ,keyword-name ',missing)) + ,@(cond ((atom head) + `((,var ,value-sym))) + ((null (cdr head)) + `((,var ,value-sym))) + ((null (cddr head)) + `((,var (if (eq ,value-sym ',missing) + ,(cadr head) + ,value-sym)))) + (t + `((,var (if (eq ,value-sym ',missing) + ,(cadr head) + ,value-sym)) + (,(caddr head) (not (eq ,value-sym ',missing))))))) + (d-b (&key ,@(cddr lambda-list)) ,environment ,whole-sym ,sym + ,@body))))) + (otherwise + (let ((sym (gensym))) + `(let ((,sym ,expression)) + (d-b ,(car lambda-list) ,environment ,whole-sym (car ,sym) + (d-b ,(cdr lambda-list) ,environment ,whole-sym (cdr ,sym) + ,@body))))))) + ((null lambda-list) + `(progn ,@body)) + (t `(let ((,lambda-list ,expression)) + ,@body))))) + + +(export '(destructuring-bind lambda-list-keywords + &allow-other-keys &aux &body &environment &key &optional &rest + &whole)) @@ -1,5 +1,5 @@ (in-package :common-lisp) (load "util.lisp") -(load "cond.lisp") (load "list-functions.lisp") +(load "destructuring-bind.lisp") (in-package :common-lisp-user) @@ -2,3 +2,198 @@ (list '%fset (list 'quote (car (cdr (car args)))) (cons '%lambda (cdr (cdr (car args)))))) + +(%defun list* args + (if (null (cdr args)) + (car args) + (cons (car args) + (apply 'list* (cdr args))))) + +(%defmacro let* args + (let ((form (car args))) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (if (null bindings) + (list* 'let nil body) + (let ((first-binding (car bindings)) + (rest (cdr bindings))) + (list 'let + (list first-binding) + (list* 'let* rest body))))))) + +(%defmacro cond args + (let* ((form (car args)) + (clauses (cdr form)) + (clause (car clauses)) + (rest (cdr clauses))) + (if (null clauses) + nil + (list 'if + (car clause) + (cons 'progn (cdr clause)) + (cons 'cond rest))))) + +(%defun not args + (if (null (car args)) t nil)) + +(%defun make-%defmacro*-body args + (let ((lambda-list (car args)) + (lambda-list-name (car (cdr args))) + (body (car (cdr (cdr args))))) + (cond ((null lambda-list) body) + ((not (listp lambda-list)) + (list + (list* 'let + (list (list lambda-list lambda-list-name)) + body))) + (t (let ((lambda-symbol (car lambda-list)) + (rest-lambda-list (cdr lambda-list)) + (rest-name (gensym))) + (list + (list* 'let + (list (list lambda-symbol + (list 'car lambda-list-name)) + (list rest-name + (list 'cdr lambda-list-name))) + (make-%defmacro*-body (cdr lambda-list) + rest-name + body)))))))) + +(%defmacro %defmacro* args + (let* ((form (car args)) + (real-args (cdr form))) + (let ((name (car real-args)) + (lambda-list (car (cdr real-args))) + (body (cdr (cdr real-args))) + (macro-lambda-list-name (gensym)) + (lambda-list-name (gensym))) + (list '%defmacro + name + macro-lambda-list-name + (list* 'let + (list (list lambda-list-name + (list 'cdr + (list 'car macro-lambda-list-name)))) + (make-%defmacro*-body lambda-list lambda-list-name body)))))) + +(%defmacro %defun* args + (let* ((form (car args)) + (real-args (cdr form))) + (let ((name (car real-args)) + (lambda-list (car (cdr real-args))) + (body (cdr (cdr real-args))) + (lambda-list-name (gensym))) + (list* '%defun + name + lambda-list-name + (make-%defmacro*-body lambda-list lambda-list-name body))))) + +(%defmacro* and expressions + (cond ((null expressions) t) + ((null (cdr expressions)) (car expressions)) + (t (list 'if + (car expressions) + (cons 'and (cdr expressions)) + nil)))) + +(%defmacro* or expressions + (cond ((null expressions) nil) + ((null (cdr expressions)) (car expressions)) + (t (let ((expr-sym (gensym))) + (list 'let + (list (list expr-sym (car expressions))) + (list 'if + expr-sym + expr-sym + (cons 'or (cdr expressions)))))))) + +(%defun* %reverse-helper (list stack) + (if (null list) + stack + (%reverse-helper (cdr list) (cons (car list) stack)))) + +(%defun* reverse (list) + (%reverse-helper list nil)) + +(%defun* %append-helper (reversed-list1 list2) + (if (null reversed-list1) + list2 + (%append-helper (cdr reversed-list1) (cons (car reversed-list1) list2)))) + +(%defun* %append-two-lists (list1 list2) + (%append-helper (reverse list1) list2)) + +(%defun* %append (lists) + (if (null (cdr lists)) + (car lists) + (let ((first-list (car lists)) + (second-list (car (cdr lists))) + (rest (cdr (cdr lists)))) + (%append (list* (%append-two-lists first-list second-list) rest))))) + +(%defun append lists + (%append lists)) + +(%defmacro* sys::quasiquote (object) + (if (not (consp object)) + (list 'quote object) + (cond ((eq 'sys::unquote (car object)) (car (cdr object))) + ((eq 'sys::quasiquote (car object)) (list 'quote object)) + ((and (consp (car object)) + (eq 'sys::unquote-splicing (car (car object)))) + (list 'append + (car (cdr (car object))) + (list 'sys::quasiquote (cdr object)))) + (t (list 'cons + (list 'sys::quasiquote (car object)) + (list 'sys::quasiquote (cdr object))))))) + +(%defun* %member (item list) + (and list + (or (and (eq item (car list)) list) + (%member item (cdr list))))) + +(%defmacro* case (object . clauses) + (let ((this-clause (car clauses)) + (rest (cdr clauses)) + (object-sym (gensym))) + (if (null clauses) + nil + (if (and (null rest) + (or (eq (car this-clause) t) + (eq (car this-clause) 'otherwise))) + `(progn ,@(cdr this-clause)) + `(let ((,object-sym ,object)) + (if ,(if (listp (car this-clause)) + `(%member ,object-sym + (quote ,(car this-clause))) + `(eq ,object-sym + (quote ,(car this-clause)))) + (progn ,@(cdr this-clause)) + (case ,object-sym ,@rest))))))) + +(%defun* list-eqp (list1 list2) + "Not really EQUALP (only works on trees of symbols)." + (if (and (consp list1) (consp list2)) + (and (list-eqp (car list1) (car list2)) + (list-eqp (cdr list1) (cdr list2))) + (eq list1 list2))) + +(%defun* macroexpand (object . rest) + (let* ((env (if rest (car rest) nil)) + (expansion-1 (macroexpand-1 object env)) + (expansion-2 (macroexpand-1 expansion-1 env))) + (if (list-eqp expansion-1 expansion-2) + expansion-1 + (macroexpand expansion-2)))) + +(%defun* macroexpand-all (object . rest) + (let* ((env (if rest (car rest) nil))) + (if (consp object) + (let ((expansion (macroexpand object env))) + (cons (macroexpand-all (car expansion)) + (macroexpand-all (cdr expansion)))) + object))) + +(%defmacro* unless (test . body) + `(if (not ,test) (progn ,@body) nil)) |