diff options
| -rw-r--r-- | MLKForeignProcedure.h | 2 | ||||
| -rw-r--r-- | MLKForeignProcedure.m | 4 | ||||
| -rw-r--r-- | MLKForm.h | 2 | ||||
| -rw-r--r-- | MLKForm.m | 10 | ||||
| -rw-r--r-- | MLKInterpreter.h | 25 | ||||
| -rw-r--r-- | MLKInterpreter.m | 1688 |
6 files changed, 597 insertions, 1134 deletions
diff --git a/MLKForeignProcedure.h b/MLKForeignProcedure.h index c01772d..160bb7c 100644 --- a/MLKForeignProcedure.h +++ b/MLKForeignProcedure.h @@ -35,7 +35,7 @@ -(id) initWithCode:(void *)code argumentTypes:(NSArray *)argTypes - returnType:(id)returnType; + returnType:(MLKForeignType)returnType; -(NSArray *) applyToArray:(NSArray *)arguments; diff --git a/MLKForeignProcedure.m b/MLKForeignProcedure.m index 459ce97..b8dab83 100644 --- a/MLKForeignProcedure.m +++ b/MLKForeignProcedure.m @@ -36,7 +36,7 @@ @implementation MLKForeignProcedure -(id) initWithCode:(void *)code argumentTypes:(NSArray *)argTypes - returnType:(id)returnType + returnType:(MLKForeignType)returnType { int i; NSEnumerator *e; @@ -45,7 +45,7 @@ self = [super init]; _code = code; - _returnType = MLKForeignTypeWithTypeDesignator (returnType); + _returnType = returnType; _argumentTypes = malloc (sizeof (MLKForeignType) * [argTypes count]); @@ -146,7 +146,7 @@ @interface MLKForeignLambdaForm : MLKCompoundForm { NSString *_foreignName; - MLKSymbol *_name; + MLKSymbol *_foreignLibraryDesignator; MLKForeignType _returnType; MLKForeignType *_argumentTypes; int _argc; @@ -18,7 +18,7 @@ #import "MLKCons.h" #import "MLKForm.h" -#import "MLKLLVMCompiler.h" +#import "MLKInterpreter.h" #import "util.h" #import "special-symbols.h" @@ -361,11 +361,11 @@ int i; self = [super complete]; - LASSIGN (_foreignName, [[_tail cdr] car]); - LASSIGN (_name, [_tail car]); - _returnType = MLKForeignTypeWithTypeDesignator ([[[_tail cdr] cdr] car]); + LASSIGN (_foreignName, [_tail car]); + LASSIGN (_foreignLibraryDesignator, [[_tail cdr] car]); + _returnType = MLKForeignTypeWithTypeDesignator ([[[[_tail cdr] cdr] cdr] car]); - argtypes = [[[_tail cdr] cdr] cdr]; + argtypes = [[[_tail cdr] cdr] car]; _argc = [argtypes length]; _argumentTypes = malloc (_argc * sizeof (MLKForeignType)); diff --git a/MLKInterpreter.h b/MLKInterpreter.h index 59e2dfd..67f7377 100644 --- a/MLKInterpreter.h +++ b/MLKInterpreter.h @@ -16,9 +16,10 @@ * along with this program. If not, see <http://www.gnu.org/licenses/>. */ -#import "MLKStream.h" +#import "MLKForm.h" #import "MLKLexicalContext.h" #import "MLKLexicalEnvironment.h" +#import "MLKStream.h" #import <Foundation/NSArray.h> #import <Foundation/NSObject.h> @@ -43,15 +44,19 @@ enum MLKProcessingMode 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; -+(NSArray*) eval:(id)program - inLexicalContext:(MLKLexicalContext *)context - withEnvironment:(MLKLexicalEnvironment *)lexenv - mode:(enum MLKProcessingMode)mode; ++(id) compile:(id)object + inContext:(MLKLexicalContext *)context; +@end -+(BOOL) load:(MLKStream *)stream verbose:(BOOL)verbose print:(BOOL)print; + +@interface MLKForm (MLKInterpretation) +-(NSArray *) interpret; +-(NSArray *) interpretWithEnvironment:(MLKLexicalEnvironment *)env; +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env; +@end + +@interface MLKBodyForm (MLKInterpretation) +-(NSArray *) interpretBodyWithEnvironment:(MLKLexicalEnvironment *)env; @end diff --git a/MLKInterpreter.m b/MLKInterpreter.m index 7fd59ad..334b33c 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -65,1126 +65,24 @@ ensure_symbols (); } - -+(NSArray*) eval:(id)program - inLexicalContext:(MLKLexicalContext *)context - withEnvironment:(MLKLexicalEnvironment *)lexenv ++(id) compile:(id)object inContext:(MLKLexicalContext *)context { - return (NSArray *)[self eval:program - inLexicalContext:context - withEnvironment:lexenv - expandOnly:NO]; + return [[self eval:object + inLexicalContext:context + withEnvironment:[MLKLexicalEnvironment globalEnvironment]] + objectAtIndex:0]; } - +(NSArray*) eval:(id)program inLexicalContext:(MLKLexicalContext *)context withEnvironment:(MLKLexicalEnvironment *)lexenv - expandOnly:(BOOL)expandOnly { - return [self eval:program - inLexicalContext:context - withEnvironment:lexenv - mode:(expandOnly ? expand_mode : eval_mode)]; -} - - -#define RETURN_VALUE(thing) \ - { return [NSArray arrayWithObject:nullify(thing)]; } - - -+(NSArray*) eval:(id)program - inLexicalContext:(MLKLexicalContext *)context - withEnvironment:(MLKLexicalEnvironment *)lexenv - mode:(enum MLKProcessingMode)mode -{ - MLKDynamicContext *dynamicContext = [MLKDynamicContext currentContext]; - BOOL expandOnly = (mode != eval_mode); - -#define TRACE_EVAL 0 -#if TRACE_EVAL - BOOL trace = NO; - - if ([dynamicContext valueForSymbol:V_INITP]) - trace = YES; - - if (trace) - NSLog (@"; EVAL: %@", MLKPrintToString(program)); -#endif // TRACE_EVAL - - if (MLKFixnumP (program)) - { - // Fixnums evaluate to themselves. - // - // We need to get this case out of the way as early as possible, - // as we're going to repeatedly send messages to `program' after - // this point. - RETURN_VALUE (program); - } - else if (!program || [program isKindOfClass:[MLKSymbol class]]) - { - if (mode == compile_time_too_mode) - { - if (![context symbolNamesSymbolMacro:program]) - { - return [self eval:program - inLexicalContext:context - withEnvironment:lexenv - mode:expand_mode]; - } - } - - //NSLog (@"Processing symbol."); - if ([context symbolNamesSymbolMacro:program]) - { - id macrofun, expansion; - - macrofun = [context macroForSymbol:program]; - expansion = [macrofun applyToArray: - [NSArray arrayWithObjects: - program, context, nil]]; - - return [self eval:expansion - inLexicalContext:context - withEnvironment:lexenv - mode:mode]; - } - else if ([context variableIsLexical:program]) - { - //NSLog (@"Processing lexical variable %@.", MLKPrintToString(program)); - //NSLog (@"Lexical environment: %@.", lexenv); - //NSLog (@"Lexical variable value: %@.", [lexenv valueForSymbol:program]); - if (expandOnly) - RETURN_VALUE (program); - - RETURN_VALUE ([lexenv valueForSymbol:program]); - } - else - { - //NSLog (@"Processing special variable %@.", MLKPrintToString(program)); - //NSLog (@"Dynamic context: %@.", dynamicContext); - //NSLog (@"Special variable value: %@.", [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_VALUE (program); - } - else - { - id car = [program car]; - - if ([car isKindOfClass:[MLKSymbol class]] || !car) - { - if (mode == compile_time_too_mode) - { - if (!([context symbolNamesMacro:program] - || car == _MACROLET || car == LOCALLY - || car == SYMBOL_MACROLET || car == PROGN)) - { - return [self eval:program - inLexicalContext:context - withEnvironment:lexenv - mode:expand_mode]; - } - } - - if (car == CATCH) - { - id catchTag; - NSArray *values; - MLKDynamicContext *newctx; - - catchTag = [[self eval:[[program cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - - NS_DURING - { - 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 - expandOnly:expandOnly]; - - if (expandOnly) - NS_VALUERETURN ([NSArray arrayWithObject: - [MLKCons - cons:CATCH - with:[MLKCons - cons:catchTag - with:[[values - objectAtIndex:0] - cdr]]]], - NSArray *); - - [MLKDynamicContext popContext]; - LRELEASE (newctx); - - NS_VALUERETURN (values, NSArray *); - } - NS_HANDLER - { - [MLKDynamicContext popContext]; - LRELEASE (newctx); - - if ([[localException name] isEqualToString:@"MLKThrow"]) - { - id thrownTag = [[localException userInfo] - objectForKey:@"THROWN TAG"]; - - if (thrownTag == catchTag) - return [[localException userInfo] - objectForKey:@"THROWN OBJECTS"]; - else - [localException raise]; - } - else - [localException raise]; - } - NS_ENDHANDLER; - - return nil; - } - else if (car == EVAL) - { - NSArray *evaluand = denullify([[self eval:[[program cdr] car] - 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]]; - } - else if (car == EVAL_WHEN) - { - id situationList = [[program cdr] car]; - id body = [[program cdr] cdr]; - NSArray *situations; - BOOL ct, lt, e; - - if (!situationList) - RETURN_VALUE (nil); - - situations = [situationList array]; - ct = ([situations containsObject:COMPILE_TOPLEVEL] - || [situations containsObject:COMPILE]); - lt = ([situations containsObject:LOAD_TOPLEVEL] - || [situations containsObject:LOAD]); - e = ([situations containsObject:EXECUTE] - || [situations containsObject:EVAL]); - - switch (mode) - { - case eval_mode: - case expand_mode: - if (e) - return [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:context - withEnvironment:lexenv - mode:mode]; - else - RETURN_VALUE (nil); - - case compile_time_too_mode: - case not_compile_time_mode: - if ((ct && lt) - || (lt && e && (mode == compile_time_too_mode))) - { - return [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:context - withEnvironment:lexenv - mode:compile_time_too_mode]; - } - else if (lt) - { - return [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:context - withEnvironment:lexenv - mode:not_compile_time_mode]; - } - else if (ct || (e && mode == compile_time_too_mode)) - { - [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:context - withEnvironment:lexenv]; - RETURN_VALUE (nil); - } - else - { - RETURN_VALUE (nil); - } - } - } - else if (car == _FOREIGN_LAMBDA) - { - int (*function)(); - NSString *name = [[program cdr] car]; - id libraryDesignator = [[[program cdr] cdr] car]; - id argtypes = [[[[program cdr] cdr] cdr] car]; - id returnType = [[[[[program cdr] cdr] cdr] cdr] car]; - - // FIXME: Support library designators. - -#ifdef _WIN32 - // FIXME - //EnumProcessModules (...); - //GetProcAddress (..., [name UTF8String]); -#else - function = dlsym (RTLD_DEFAULT, [name UTF8String]); -#endif - - RETURN_VALUE (LAUTORELEASE ([[MLKForeignProcedure alloc] - initWithCode:function - argumentTypes:[argtypes array] - returnType:returnType])); - } - else if (car == FUNCTION) - { - id functionName = [[program cdr] car]; - - if ([functionName isKindOfClass:[MLKCons class]] - && ([functionName car] == LAMBDA - || [functionName car] == _LAMBDA)) - { - return [self eval:functionName - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly]; - } - else if (expandOnly) - { - RETURN_VALUE (program); - } - else - { - // FIXME: Function names need not be symbols. - id <MLKFuncallable> function = - [lexenv functionForSymbol:functionName]; - RETURN_VALUE (function); - } - } - else if (car == IF) - { - id condition = [[program cdr] car]; - id consequent = [[[program cdr] cdr] car]; - // Incidentally works for the two-clause case: - id alternative = [[[[program cdr] cdr] cdr] car]; - - 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 - expandOnly:expandOnly]; - else - return [self eval:consequent - inLexicalContext:context - 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)]; - - [[MLKDynamicContext currentContext] - setValue:package - forSymbol:[[MLKPackage findPackage:@"COMMON-LISP"] - intern:@"*PACKAGE*"]]; - - RETURN_VALUE (package); - } - else if (car == _LAMBDA) - { - // A bare-bones LAMBDA without a real lambda list. What - // would be a lambda list in a real LAMBDA form must be a - // symbol here. - id lambdaList = [[program cdr] car]; - 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 = LAUTORELEASE ([[MLKInterpretedClosure alloc] - initWithBodyForms:body - lambdaListName:lambdaList - context:context - environment:lexenv]); - return [NSArray arrayWithObject:nullify(closure)]; - } - else if (car == _MACROLET) - { - id declarations, doc; - id clauses; - id body; - NSArray *result; - MLKLexicalContext *ctx; - - MLKSplitDeclarationsDocAndForms (&declarations, &doc, &body, - [[program cdr] cdr], NO); - ctx = LAUTORELEASE ([[MLKLexicalContext alloc] - initWithParent:context - variables:nil - functions:nil - goTags:nil - macros:nil - compilerMacros:nil - symbolMacros:nil - declarations:declarations]); - - clauses = [[program cdr] car]; - while (clauses) - { - id clause = [clauses car]; - id name, value; - - name = [clause car]; - value = denullify([[self eval:[MLKCons cons:_LAMBDA - with:[clause cdr]] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:NO] //! - objectAtIndex:0]); - - [ctx addMacro:value forSymbol:name]; - - clauses = [clauses cdr]; - } - - result = [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:ctx - withEnvironment:lexenv - mode:mode]; - - if (expandOnly) - { - RETURN_VALUE ([MLKCons - cons:LET - with:[MLKCons - cons:nil - with:[MLKCons - cons:[MLKCons cons:DECLARE - with:declarations] - with:[[result objectAtIndex:0] cdr]]]]); - } - else - { - return result; - } - } - else if (car == _FLET) - { - id declarations, doc; - id clauses; - NSMutableArray *new_clauses; - id body; - NSArray *result; - MLKLexicalContext *ctx; - MLKLexicalEnvironment *env; - - MLKSplitDeclarationsDocAndForms (&declarations, &doc, &body, - [[program cdr] cdr], NO); - - ctx = LAUTORELEASE ([[MLKLexicalContext alloc] - initWithParent:context - variables:nil - functions:nil - goTags:nil - macros:nil - compilerMacros:nil - symbolMacros:nil - declarations:declarations]); - - if (!expandOnly) - env = LAUTORELEASE ([[MLKLexicalEnvironment alloc] - initWithParent:lexenv - variables:nil - functions:nil]); - - clauses = [[program cdr] car]; - new_clauses = [NSMutableArray array]; - while (clauses) - { - id clause = [clauses car]; - id name, value; - - name = [clause car]; - - value = denullify([[self eval:[MLKCons cons:_LAMBDA - with:[clause cdr]] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - - [ctx addFunction:name]; - - if (!expandOnly) - [env addFunction:value forSymbol:name]; - else - [new_clauses addObject:[MLKCons cons:name with:[value cdr]]]; - - clauses = [clauses cdr]; - } - - result = [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:ctx - withEnvironment:(expandOnly ? lexenv : env) - expandOnly:expandOnly]; - - if (expandOnly) - { - RETURN_VALUE ([MLKCons - cons:_FLET - with:[MLKCons - cons:[MLKCons listWithArray:new_clauses] - with:[MLKCons - cons:[MLKCons cons:DECLARE - with:declarations] - with:[[result objectAtIndex:0] cdr]]]]); - } - else - { - return result; - } - } - else if (car == LET) - { - id declarations, doc; - id clauses; - id body; - NSArray *result; - NSMutableArray *new_clauses; - MLKLexicalContext *ctx; - MLKLexicalEnvironment *env; - MLKDynamicContext *dynctx; - - MLKSplitDeclarationsDocAndForms (&declarations, &doc, &body, - [[program cdr] cdr], NO); - - ctx = LAUTORELEASE ([[MLKLexicalContext alloc] - initWithParent:context - variables:nil - functions:nil - goTags:nil - macros:nil - compilerMacros:nil - symbolMacros:nil - declarations:declarations]); - - if (!expandOnly) - { - env = LAUTORELEASE ([[MLKLexicalEnvironment alloc] - initWithParent:lexenv - variables:nil - functions:nil]); - - dynctx = [[MLKDynamicContext alloc] - initWithParent:dynamicContext - variables:nil - handlers:nil - restarts:nil - catchTags:nil - activeHandlerEnvironment:nil]; - } - - clauses = [[program cdr] car]; - new_clauses = [NSMutableArray array]; - while (clauses) - { - id clause = [clauses car]; - id variable, value; - - if (!clause || [clause isKindOfClass:[MLKSymbol class]]) - { - variable = clause; - value = nil; - } - else if ([clause cdr] == nil) - { - variable = [clause car]; - value = nil; - } - else - { - variable = [clause car]; - value = denullify([[self eval:[[clause cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - } - - if (expandOnly) - { - [new_clauses addObject:[MLKCons cons:variable - with:[MLKCons cons:value - with:nil]]]; - } - else - { - [ctx addVariable:variable]; - if ([ctx variableIsLexical:variable]) - { - [env addValue:value forSymbol:variable]; - } - else - { - [dynctx addValue:value forSymbol:variable]; - } - } - - clauses = [clauses cdr]; - } - - if (expandOnly) - { - result = [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:ctx - withEnvironment:lexenv - expandOnly:YES]; - - RETURN_VALUE ([MLKCons - cons:LET - with:[MLKCons - cons:[MLKCons listWithArray:new_clauses] - with:[MLKCons - cons:[MLKCons cons:DECLARE - with:declarations] - with:[[result objectAtIndex:0] cdr]]]]); - } - else - { - [dynctx pushContext]; - - NS_DURING - { - result = [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:ctx - withEnvironment:env - expandOnly:NO]; - } - NS_HANDLER - { - [MLKDynamicContext popContext]; - [localException raise]; - } - NS_ENDHANDLER; - - [MLKDynamicContext popContext]; - LRELEASE (dynctx); - - return result; - } - } - else if (car == _LOOP) - { - id rest; - - if (expandOnly) - { - RETURN_VALUE ([MLKCons cons:_LOOP - with:[[[self eval:[MLKCons cons:PROGN - with:[program cdr]] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:YES] - objectAtIndex:0] - cdr]]); - } - - while (YES) - { - rest = program; - while ((rest = [rest cdr])) - { - [self eval:[rest car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly]; - } - } - - RETURN_VALUE (nil); // never reached - } - else if (car == MULTIPLE_VALUE_CALL) - { - NSMutableArray *results = [NSMutableArray array]; - id rest = [program cdr]; - id function = [[self eval:[rest car] - inLexicalContext:context - withEnvironment:lexenv - mode:mode] - objectAtIndex:0]; - - while ((rest = [rest cdr])) - { - id values = [self eval:[rest car] - inLexicalContext:context - withEnvironment:lexenv - mode:mode]; - [results addObjectsFromArray:values]; - } - - if (expandOnly) - { - RETURN_VALUE ([MLKCons - cons:MULTIPLE_VALUE_CALL - with:[MLKCons - cons:function - with:[MLKCons - listWithArray:results]]]); - } - else - { - return [function applyToArray:results]; - } - } - else if (car == PROGN) - { - id result = nil; - id rest = program; - NSMutableArray *results = [NSMutableArray array]; - while ((rest = [rest cdr])) - { - result = [self eval:[rest car] - inLexicalContext:context - withEnvironment:lexenv - mode:mode]; - if (expandOnly) - [results addObjectsFromArray:result]; - } - - if (expandOnly) - { - RETURN_VALUE ([MLKCons cons:PROGN - with:[MLKCons listWithArray:results]]); - } - else - return result; - } - else if (car == PROGV) - { - id variables, values, body, result; - MLKDynamicContext *dynctx; - - if (expandOnly) - { - RETURN_VALUE ([MLKCons - cons:PROGV - with:[denullify([[self eval:[MLKCons - cons:PROGN - with:[program cdr]] - inLexicalContext:context - withEnvironment:lexenv - mode:mode] - objectAtIndex:0]) cdr]]); - } - - dynctx = [[MLKDynamicContext alloc] - initWithParent:dynamicContext - variables:nil - handlers:nil - restarts:nil - catchTags:nil - activeHandlerEnvironment:nil]; - - body = [[[program cdr] cdr] cdr]; - variables = denullify ([[self eval:[[program cdr] car] - inLexicalContext:context - withEnvironment:lexenv] - objectAtIndex:0]); - values = denullify ([[self eval:[[[program cdr] cdr] car] - inLexicalContext:context - withEnvironment:lexenv] - objectAtIndex:0]); - - for (; variables; (variables = [variables cdr], values = [values cdr])) - { - id var = [variables car]; - id value = [values car]; - - [dynctx addValue:value forSymbol:var]; - } - - [dynctx pushContext]; - - NS_DURING - { - result = [self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:context - withEnvironment:lexenv]; - } - NS_HANDLER - { - [MLKDynamicContext popContext]; - [localException raise]; - } - NS_ENDHANDLER; - - [MLKDynamicContext popContext]; - LRELEASE (dynctx); - - return result; - } - else if (car == QUOTE) - { - if (expandOnly) - RETURN_VALUE (program); - RETURN_VALUE ([[program cdr] car]); - } - else if (car == SETQ || car == _FSETQ) - { - id symbol = [[program cdr] car]; - id value = [[self eval:[[[program cdr] cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - id rest = [[[program cdr] cdr] cdr]; - - if (![program cdr]) - RETURN_VALUE (nil); - - if (car == SETQ && [context symbolNamesSymbolMacro:symbol]) - { - id macrofun = [context symbolMacroForSymbol:symbol]; - id expansion = [macrofun applyToArray: - [NSArray arrayWithObjects: - program, context, nil]]; - return [self eval: - [MLKCons cons:SETF - with: - [MLKCons cons:expansion - with: - [[program cdr] cdr]]] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly]; - } - - if (expandOnly) - { - id thisSETQ = [MLKCons - cons:car - with:[MLKCons - cons:symbol - with:[MLKCons - cons:value - with:nil]]]; - id more = denullify([[self eval:[MLKCons cons:car with:rest] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - - if (!more) - { - RETURN_VALUE (thisSETQ); - } - else - { - RETURN_VALUE ([MLKCons cons:PROGN - with:[MLKCons - cons:thisSETQ - with:[MLKCons - cons:more - with:nil]]]); - - } - } - - if (car == _FSETQ) - { - if ([context symbolNamesFunction:symbol]) - { - [lexenv setFunction:value forSymbol:symbol]; - } - else - { - // FIXME: Maybe print a warning. - [[MLKLexicalContext globalContext] addFunction:symbol]; - [[MLKLexicalEnvironment globalEnvironment] - addFunction:value - forSymbol:symbol]; - } - } - else if ([context variableIsLexical:symbol]) - [lexenv setValue:value forSymbol:symbol]; - else if ([dynamicContext bindingForSymbol:symbol]) - [dynamicContext setValue:value forSymbol:symbol]; - else - // FIXME: Maybe print a warning. - [[MLKDynamicContext globalContext] addValue:value - forSymbol:symbol]; - - - if (rest) - return [self eval:[MLKCons cons:car with:rest] - inLexicalContext:context - withEnvironment:lexenv]; - else - RETURN_VALUE (value); - } - else if (car == THROW) - { - id catchTag; - NSArray *values; - NSDictionary *userInfo; - - catchTag = [[self eval:[[program cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - - values = [self eval:[[[program cdr] cdr] car] - inLexicalContext:context - 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", - values, @"THROWN OBJECTS", nil]; - - if ([dynamicContext catchTagIsEstablished:denullify (catchTag)]) - [[NSException exceptionWithName:@"MLKThrow" - reason:[NSString stringWithFormat: - @"THROW: tag %@, values %@.", - MLKPrintToString(catchTag), - MLKPrintToString(values)] - userInfo:userInfo] raise]; - else - // FIXME: This should really be a condition rather than - // an exception. See CLHS THROW. - [[NSException exceptionWithName:@"MLKControlError" - reason:[NSString stringWithFormat: - @"THROW without a corresponding CATCH: tag %@, values %@.", - MLKPrintToString(catchTag), - MLKPrintToString(values)] - userInfo:userInfo] raise]; - - return nil; - } - else if (car == UNWIND_PROTECT) - { - 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] - inLexicalContext:context - withEnvironment:lexenv]; - } - NS_HANDLER - { - [self eval:[MLKCons cons:PROGN with:[[program cdr] cdr]] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly]; - - [localException raise]; - } - NS_ENDHANDLER; - - [self eval:[MLKCons cons:PROGN with:[[program cdr] cdr]] - inLexicalContext:context - withEnvironment:lexenv]; - - return results; - } - else - { - if ([context symbolNamesFunction:car]) - { - id function; - MLKCons *rest = [program cdr]; - NSMutableArray *args = [NSMutableArray array]; - - while (rest) - { - id result = [[self eval:[rest car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - [args addObject:result]; - rest = [rest cdr]; - } - - 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]) - { - id macrofun = [context macroForSymbol:car]; - id expansion = denullify([[macrofun - applyToArray: - [NSArray arrayWithObjects: - program, context, nil]] - objectAtIndex:0]); - - return [self eval:expansion - inLexicalContext:context - withEnvironment:lexenv - mode:mode]; - } - else - { - NSMutableArray *args = [NSMutableArray array]; - MLKCons *rest = [program cdr]; - NSArray *results; - - while (rest) - { - id result = [[self eval:[rest car] - inLexicalContext:context - 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) - { - return results; - } - else - { - [NSException raise:@"MLKNoSuchOperatorException" - format:@"%@ does not name a known operator.", - MLKPrintToString(car)]; - return nil; - } - } - } - } - else if ([car isKindOfClass:[MLKCons class]] && [car car] == LAMBDA) - { - return [self eval:[MLKCons cons:FUNCALL with:program] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly]; - } - else - { - [NSException raise:@"MLKInvalidExpressionException" - format:@"%@ is not a valid operator name.", - MLKPrintToString(car)]; - return nil; - } - } + id form = [MLKForm formWithObject:program + inContext:context + forCompiler:self]; + return [form interpretWithEnvironment:lexenv]; } - +(BOOL) load:(MLKStream *)stream verbose:(BOOL)verbose print:(BOOL)print { id eofValue = [[NSObject alloc] init]; @@ -1243,8 +141,7 @@ inLexicalContext:[MLKLexicalContext globalContext] withEnvironment:[MLKLexicalEnvironment - globalEnvironment] - mode:not_compile_time_mode] + globalEnvironment]] objectAtIndex:0]); if ([code isKindOfClass:[MLKCons class]] && [code cdr]) @@ -1258,8 +155,7 @@ result = [MLKInterpreter eval:expansion inLexicalContext:[MLKLexicalContext globalContext] - withEnvironment:[MLKLexicalEnvironment globalEnvironment] - expandOnly:NO]; + withEnvironment:[MLKLexicalEnvironment globalEnvironment]]; //NSLog (@"; LOAD: Top-level form evaluated."); } @@ -1276,3 +172,565 @@ return YES; } @end + + +#define RETURN_VALUE(thing) \ +{ return [NSArray arrayWithObject:nullify(thing)]; } + + +@implementation MLKForm (MLKInterpretation) +-(NSArray *) interpret +{ + return [self interpretWithEnvironment:[MLKLexicalEnvironment globalEnvironment]]; +} + + +-(NSArray *) interpretWithEnvironment:(MLKLexicalEnvironment *)env +{ +#define TRACE_EVAL 0 +#if TRACE_EVAL + BOOL trace = NO; + + if ([dynamicContext valueForSymbol:V_INITP]) + trace = YES; + + if (trace) + NSLog (@"; EVAL: %@", MLKPrintToString(program)); +#endif // TRACE_EVAL + + return [self reallyInterpretWithEnvironment:env]; +} + + +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + NSLog (@"WARNING: Unrecognised form type: %@", self); + return [NSArray array]; +} +@end + + +@implementation MLKSelfEvaluatingForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + RETURN_VALUE (_form); +} +@end + + +@implementation MLKSymbolForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + if ([_context symbolNamesSymbolMacro:_form]) + { + id macrofun, expansion; + + macrofun = [_context macroForSymbol:_form]; + expansion = [macrofun applyToArray: + [NSArray arrayWithObjects: + _form, _context, nil]]; + + return [expansion interpretWithEnvironment:env]; + } + else if ([_context variableIsLexical:_form]) + { + RETURN_VALUE ([env valueForSymbol:_form]); + } + else + { + RETURN_VALUE ([[MLKDynamicContext currentContext] valueForSymbol:_form]); + } +} +@end + + +@implementation MLKCatchForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id catchTag; + NSArray *values; + MLKDynamicContext *newctx; + + catchTag = [[_tagForm interpretWithEnvironment:env] objectAtIndex:0]; + + NS_DURING + { + newctx = [[MLKDynamicContext alloc] initWithParent:[MLKDynamicContext currentContext] + variables:nil + handlers:nil + restarts:nil + catchTags:[NSSet setWithObject:catchTag] + activeHandlerEnvironment:nil]; + [newctx pushContext]; + + values = [self interpretBodyWithEnvironment:env]; + + [MLKDynamicContext popContext]; + LRELEASE (newctx); + + NS_VALUERETURN (values, NSArray *); + } + NS_HANDLER + { + [MLKDynamicContext popContext]; + LRELEASE (newctx); + + if ([[localException name] isEqualToString:@"MLKThrow"]) + { + id thrownTag = [[localException userInfo] + objectForKey:@"THROWN TAG"]; + + if (thrownTag == catchTag) + return [[localException userInfo] + objectForKey:@"THROWN OBJECTS"]; + else + [localException raise]; + } + else + [localException raise]; + } + NS_ENDHANDLER; + + return nil; +} +@end + + +@implementation MLKForeignLambdaForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + // FIXME: Support library designators. + + int (*function)(); + +#ifdef _WIN32 + // FIXME + //EnumProcessModules (...); + //GetProcAddress (..., [_foreignName UTF8String]); +#else + function = dlsym (RTLD_DEFAULT, [_foreignName UTF8String]); +#endif + + NSMutableArray *argtypes = [NSMutableArray array]; + int i; + for (i = 0; i++; i < _argc) + [argtypes addObject:[NSNumber numberWithInt:_argumentTypes[i]]]; + + RETURN_VALUE (LAUTORELEASE ([[MLKForeignProcedure alloc] + initWithCode:function + argumentTypes:argtypes + returnType:_returnType])); +} +@end + + +@implementation MLKLambdaFunctionForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + return [_lambdaForm interpretWithEnvironment:env]; +} +@end + + +@implementation MLKSimpleFunctionForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + RETURN_VALUE ([env functionForSymbol:_functionName]); +} +@end + + +@implementation MLKIfForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id cndval = [[_conditionForm interpretWithEnvironment:env] objectAtIndex:0]; + if (cndval) + return [_consequentForm interpretWithEnvironment:env]; + else + return [_alternativeForm interpretWithEnvironment:env]; +} +@end + + +@implementation MLKInPackageForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id package = [MLKPackage findPackage:stringify(_packageDesignator)]; + + [[MLKDynamicContext currentContext] + setValue:package + forSymbol:[[MLKPackage findPackage:@"COMMON-LISP"] + intern:@"*PACKAGE*"]]; + + RETURN_VALUE (package); +} +@end + + +@implementation MLKLambdaForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id lambdaList = [_tail car]; + id body = [_tail cdr]; + id closure = LAUTORELEASE ([[MLKInterpretedClosure alloc] + initWithBodyForms:_body + lambdaListName:lambdaList + context:_context + environment:env]); + RETURN_VALUE (closure); +} +@end + + +@implementation MLKSimpleFletForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + int i; + MLKLexicalEnvironment *newenv = [MLKLexicalEnvironment environmentWithParent:env + variables:nil + functions:nil]; + + for (i = 0; i < [_functionBindingForms count]; i++) + { + [[_functionBindingForms objectAtIndex:i] interpretWithEnvironment:newenv]; + } + + return [self interpretBodyWithEnvironment:newenv]; +} +@end + + +@implementation MLKSimpleFunctionBindingForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id value = [_compiler compile:[MLKCons cons:_LAMBDA with:_tail] + inContext:_context]; + [env addFunction:value forSymbol:_name]; + return nil; +} +@end + + +@implementation MLKLetForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + int i; + NSArray *values; + MLKLexicalEnvironment *newenv; + MLKDynamicContext *dynctx; + + newenv = [MLKLexicalEnvironment environmentWithParent:env + variables:nil + functions:nil]; + dynctx = [[MLKDynamicContext alloc] initWithParent:[MLKDynamicContext currentContext] + variables:nil + handlers:nil + restarts:nil + catchTags:nil + activeHandlerEnvironment:nil]; + + for (i = 0; i < [_variableBindingForms count]; i++) + { + id variable = [[_variableBindingForms objectAtIndex:i] name]; + id value = [[[_variableBindingForms objectAtIndex:i] + interpretWithEnvironment:env] + objectAtIndex:0]; + if ([_context variableIsLexical:variable]) + { + [newenv addValue:value forSymbol:variable]; + } + else + { + [dynctx addValue:value forSymbol:variable]; + } + } + + [dynctx pushContext]; + + NS_DURING + { + values = [self interpretBodyWithEnvironment:newenv]; + } + NS_HANDLER + { + [MLKDynamicContext popContext]; + LRELEASE (dynctx); + [localException raise]; + } + NS_ENDHANDLER; + + [MLKDynamicContext popContext]; + LRELEASE (dynctx); + + return values; +} +@end + + +@implementation MLKSimpleLoopForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + while (YES) + { + [self interpretBodyWithEnvironment:env]; + } + + RETURN_VALUE (nil); // never reached +} +@end + + +@implementation MLKMultipleValueCallForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + NSMutableArray *results = [NSMutableArray array]; + int i; + id <MLKFuncallable> function = [[_functionForm interpretWithEnvironment:env] objectAtIndex:0]; + + for (i = 0; i < [_bodyForms count]; i++) + { + NSArray *values = [[_bodyForms objectAtIndex:i] interpretWithEnvironment:env]; + [results addObjectsFromArray:values]; + } + + return [function applyToArray:results]; +} +@end + + +@implementation MLKProgNForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + return [self interpretBodyWithEnvironment:env]; +} +@end + + +@implementation MLKBodyForm (MLKInterpretation) +-(NSArray *) interpretBodyWithEnvironment:(MLKLexicalEnvironment *)env +{ + int i; + NSArray *values = nil; + + for (i = 0; i < [_bodyForms count]; i++) + { + values = [[_bodyForms objectAtIndex:i] interpretWithEnvironment:env]; + } + + return values; +} +@end + + +@implementation MLKProgVForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id variables = [[_variableListForm interpretWithEnvironment:env] + objectAtIndex:0]; + id values = [[_valueListForm interpretWithEnvironment:env] + objectAtIndex:0]; + MLKDynamicContext *dynctx; + id result; + + dynctx = [[MLKDynamicContext alloc] + initWithParent:[MLKDynamicContext currentContext] + variables:nil + handlers:nil + restarts:nil + catchTags:nil + activeHandlerEnvironment:nil]; + + for (; variables; (variables = [variables cdr], values = [values cdr])) + { + id var = [variables car]; + id value = [values car]; + + [dynctx addValue:value forSymbol:var]; + } + + [dynctx pushContext]; + + NS_DURING + { + result = [self interpretBodyWithEnvironment:env]; + } + NS_HANDLER + { + [MLKDynamicContext popContext]; + LRELEASE (dynctx); + [localException raise]; + } + NS_ENDHANDLER; + + [MLKDynamicContext popContext]; + LRELEASE (dynctx); + + return result; +} +@end + + +@implementation MLKQuoteForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + return _quotedData; +} +@end + + +@implementation MLKThrowForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + id catchTag; + NSArray *values; + NSDictionary *userInfo; + + catchTag = [[_tagForm interpretWithEnvironment:env] objectAtIndex:0]; + values = [_valueForm interpretWithEnvironment:env]; + + userInfo = [NSDictionary dictionaryWithObjectsAndKeys: + catchTag, @"THROWN TAG", + values, @"THROWN OBJECTS", nil]; + + if ([[MLKDynamicContext currentContext] catchTagIsEstablished:denullify (catchTag)]) + [[NSException exceptionWithName:@"MLKThrow" + reason:[NSString stringWithFormat: + @"THROW: tag %@, values %@.", + MLKPrintToString(catchTag), + MLKPrintToString(values)] + userInfo:userInfo] raise]; + else + // FIXME: This should really be a condition rather than + // an exception. See CLHS THROW. + [[NSException exceptionWithName:@"MLKControlError" + reason:[NSString stringWithFormat: + @"THROW without a corresponding CATCH: tag %@, values %@.", + MLKPrintToString(catchTag), + MLKPrintToString(values)] + userInfo:userInfo] raise]; + + return nil; +} +@end + + +@implementation MLKUnwindProtectForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + NSArray *results; + + NS_DURING + { + results = [_protectedForm interpretWithEnvironment:env]; + } + NS_HANDLER + { + [self interpretBodyWithEnvironment:env]; + [localException raise]; + } + NS_ENDHANDLER; + + [self interpretBodyWithEnvironment:env]; + + return results; +} +@end + + +@implementation MLKFunctionCallForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + int i; + NSArray *results = nil; + NSMutableArray *args = [NSMutableArray array]; + + for (i = 0; i < [_argumentForms count]; i++) + { + id result = [[[_argumentForms objectAtIndex:i] + interpretWithEnvironment:env] + objectAtIndex:0]; + [args addObject:result]; + } + + if (![_context symbolNamesFunction:_head]) + { + if (_head && [_head homePackage] == sys) + { + results = [MLKRoot dispatch:_head withArguments:args]; + } + + if (results) + { + return results; + } + else + { + [NSException raise:@"MLKNoSuchOperatorException" + format:@"%@ does not name a known operator.", + MLKPrintToString(_head)]; + return nil; + } + } + else + { + id <MLKFuncallable> function = [env functionForSymbol:_head]; + return [function applyToArray:args]; + } +} +@end + + +@implementation MLKSetQForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + int i; + id value = nil; + MLKDynamicContext *dynamicContext = [MLKDynamicContext currentContext]; + + for (i = 0; i < [_variables count]; i++) + { + id symbol = denullify([_variables objectAtIndex:i]); + value = [[[_valueForms objectAtIndex:i] interpretWithEnvironment:env] objectAtIndex:0]; + + if ([_context variableIsLexical:symbol]) + [env setValue:value forSymbol:symbol]; + else if ([dynamicContext bindingForSymbol:symbol]) + [dynamicContext setValue:value forSymbol:symbol]; + else + // FIXME: Maybe print a warning. + [[MLKDynamicContext globalContext] addValue:value + forSymbol:symbol]; + } + + RETURN_VALUE (value); +} +@end + + +@implementation MLKFSetQForm (MLKInterpretation) +-(NSArray *) reallyInterpretWithEnvironment:(MLKLexicalEnvironment *)env +{ + int i; + id value = nil; + + for (i = 0; i < [_functionNames count]; i++) + { + id symbol = denullify([_functionNames objectAtIndex:i]); + value = [[[_valueForms objectAtIndex:i] interpretWithEnvironment:env] objectAtIndex:0]; + + if ([_context symbolNamesFunction:symbol]) + { + [env setFunction:value forSymbol:symbol]; + } + else + { + // FIXME: Maybe print a warning. + [[MLKLexicalContext globalContext] addFunction:symbol]; + [[MLKLexicalEnvironment globalEnvironment] addFunction:value + forSymbol:symbol]; + } + } + + RETURN_VALUE (value); +} +@end |