summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <mulk@Minimulk.local>2008-08-24 17:03:33 +0200
committerMatthias Benkard <mulk@Minimulk.local>2008-08-24 17:03:33 +0200
commit3fd292f83ef33f8052feb22eb133d37913d33c66 (patch)
tree67ce92a5dc1e374e67c097ffcbf0c78008ab2271
parentf4240af04599a9b25645ecae78e5a45b46247cca (diff)
Refactor the interpreter so as to build upon the MLKForm class cluster.
The transition is not finished yet, so lots of things are broken right now.
-rw-r--r--MLKForeignProcedure.h2
-rw-r--r--MLKForeignProcedure.m4
-rw-r--r--MLKForm.h2
-rw-r--r--MLKForm.m10
-rw-r--r--MLKInterpreter.h25
-rw-r--r--MLKInterpreter.m1688
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]);
diff --git a/MLKForm.h b/MLKForm.h
index 5263dbd..a57faa3 100644
--- a/MLKForm.h
+++ b/MLKForm.h
@@ -146,7 +146,7 @@
@interface MLKForeignLambdaForm : MLKCompoundForm
{
NSString *_foreignName;
- MLKSymbol *_name;
+ MLKSymbol *_foreignLibraryDesignator;
MLKForeignType _returnType;
MLKForeignType *_argumentTypes;
int _argc;
diff --git a/MLKForm.m b/MLKForm.m
index c8a5416..16ab207 100644
--- a/MLKForm.m
+++ b/MLKForm.m
@@ -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