MLKInterpreter: Implement the %LAMBDA operator.

12 files changed, 267 insertions, 23 deletions

diff --git a/GNUmakefile b/GNUmakefile
index de97da6..0ec256b 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -27,16 +27,16 @@ ADDITIONAL_OBJCFLAGS = -Wall
 
 ToiletKit_OBJC_FILES = MLKCharacter.m MLKCons.m MLKBinding.m		\
                        MLKDoubleFloat.m MLKDynamicContext.m		\
-                       MLKEndOfFileError.m MLKEnvironment.m		\
-                       MLKFloat.m MLKInteger.m MLKInterpreter.m		\
-                       MLKLinkedList.m MLKLexicalContext.m		\
-                       MLKLexicalEnvironment.m MLKLispValue.m		\
-                       MLKPackage.m MLKParenReader.m MLKRatio.m		\
-                       MLKReader.m MLKReadtable.m MLKReaderError.m	\
-                       MLKSingleFloat.m MLKStream.m			\
+                       MLKEndOfFileError.m MLKEnvironment.m MLKFloat.m	\
+                       MLKInteger.m MLKInterpretedClosure.m		\
+                       MLKInterpreter.m MLKLinkedList.m			\
+                       MLKLexicalContext.m MLKLexicalEnvironment.m	\
+                       MLKLispValue.m MLKPackage.m MLKParenReader.m	\
+                       MLKRatio.m MLKReader.m MLKReadtable.m		\
+                       MLKReaderError.m MLKSingleFloat.m MLKStream.m	\
                        MLKStringInputStream.m MLKSymbol.m		\
-                       MLKThrowException.m				\
-                       NSObject-MLKPrinting.m NSString-MLKPrinting.m
+                       MLKThrowException.m NSObject-MLKPrinting.m	\
+                       NSString-MLKPrinting.m
 ToiletKit_LDFLAGS = -lgmp
 #LIBRARIES_DEPEND_UPON
 
diff --git a/MLKClosure.h b/MLKClosure.h
index e8a20d4..8fd30d7 100644
--- a/MLKClosure.h
+++ b/MLKClosure.h
@@ -17,9 +17,12 @@
  */
 
 #import "MLKLispValue.h"
+#import "MLKEnvironment.h"
 #import "MLKFuncallable.h"
+#import "MLKFunction.h"
 
-@class MLKFunction, NSArray, NSData;
+#import <Foundation/NSArray.h>
+#import <Foundation/NSData.h>
 
 
 @interface MLKClosure : MLKLispValue <MLKFuncallable>
diff --git a/MLKCons.h b/MLKCons.h
index a93e3d2..739fb40 100644
--- a/MLKCons.h
+++ b/MLKCons.h
@@ -28,6 +28,7 @@
 }
 
 +(MLKCons*) cons:(id)car with:(id)cdr;
++(MLKCons*) listWithArray:(NSArray *)array;
 
 -(MLKCons*) initWithCar:(id)car cdr:(id)cdr;
 
diff --git a/MLKCons.m b/MLKCons.m
index b2b3b8b..f56cfd7 100644
--- a/MLKCons.m
+++ b/MLKCons.m
@@ -26,7 +26,7 @@
 @implementation MLKCons
 +(MLKCons*) cons:(id)car with:(id)cdr
 {
-  return AUTORELEASE ([[MLKCons alloc] initWithCar:car cdr:cdr]);
+  return AUTORELEASE ([[self alloc] initWithCar:car cdr:cdr]);
 }
 
 -(MLKCons*) initWithCar:(id)car cdr:(id)cdr
@@ -37,6 +37,30 @@
   return self;
 }
 
++(MLKCons*) listWithArray:(NSArray *)array
+{
+  MLKCons *cons, *tail;
+  int i;
+
+  cons = nil;
+  tail = nil;
+
+  for (i = 0; i < [array count]; i++)
+    {
+      id item = [array objectAtIndex:i];
+      if (!tail)
+        {
+          cons = tail = [MLKCons cons:item with:nil];
+        }
+      else
+        {
+          [tail setCdr:[MLKCons cons:item with:nil]];
+          tail = [tail cdr];
+        }
+    }
+
+  return cons;
+}
 
 -(id) car
 {
diff --git a/MLKInterpretedClosure.h b/MLKInterpretedClosure.h
new file mode 100644
index 0000000..5d1ac25
--- /dev/null
+++ b/MLKInterpretedClosure.h
@@ -0,0 +1,45 @@
+/* -*- 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 "MLKLexicalContext.h"
+#import "MLKLexicalEnvironment.h"
+
+#import <Foundation/NSArray.h>
+#import <Foundation/NSString.h>
+
+
+@interface MLKInterpretedClosure : MLKLispValue <MLKFuncallable>
+{
+  id bodyForm;
+  MLKSymbol *lambdaListName;
+  MLKLexicalContext *context;
+  MLKLexicalEnvironment *environment;
+}
+
+-(id) initWithBodyForm:(id)form
+        lambdaListName:(MLKSymbol *)symbol
+               context:(MLKLexicalContext *)lexctx
+           environment:(MLKLexicalEnvironment *)lexenv;
+
+-(NSArray *) applyToArray:(NSArray *)arguments;
+
+-(NSString *) description;
+-(NSString *) descriptionForLisp;
+@end
diff --git a/MLKInterpretedClosure.m b/MLKInterpretedClosure.m
new file mode 100644
index 0000000..48f1805
--- /dev/null
+++ b/MLKInterpretedClosure.m
@@ -0,0 +1,75 @@
+/* -*- 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 "MLKCons.h"
+#import "MLKInterpretedClosure.h"
+#import "MLKInterpreter.h"
+#import "runtime-compatibility.h"
+
+#import <Foundation/NSDictionary.h>
+#import <Foundation/NSSet.h>
+
+
+@implementation MLKInterpretedClosure
+-(id) initWithBodyForm:(id)form
+        lambdaListName:(MLKSymbol *)symbol
+               context:(MLKLexicalContext *)lexctx
+           environment:(MLKLexicalEnvironment *)lexenv
+{
+  self = [super init];
+  ASSIGN (bodyForm, form);
+  ASSIGN (context, lexctx);
+  ASSIGN (environment, lexenv);
+  ASSIGN (lambdaListName, symbol);
+  return self;
+}
+
+-(NSArray *) applyToArray:(NSArray *)arguments
+{
+  id arglist = [MLKCons listWithArray:arguments];
+
+  MLKLexicalEnvironment *new_environment =
+    [MLKLexicalEnvironment environmentWithParent:environment
+                           variables:[NSDictionary dictionaryWithObject:arglist
+                                                   forKey:lambdaListName]
+                           functions:nil];
+
+  MLKLexicalContext *new_context =
+    [MLKLexicalContext contextWithParent:context
+                       variables:[NSSet setWithObject:lambdaListName]
+                       functions:nil
+                       goTags:nil
+                       macros:nil
+                       symbolMacros:nil
+                       declarations:nil];
+
+  return [MLKInterpreter eval:bodyForm
+                         inLexicalContext:new_context
+                         withEnvironment:new_environment];
+}
+
+-(NSString *) description
+{
+  return [self descriptionForLisp];
+}
+
+-(NSString *) descriptionForLisp
+{
+  return [NSString stringWithFormat:@"<Interpreted closure @%p>", self];
+}
+@end
diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index 79b8794..01a915f 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -16,6 +16,7 @@
  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#import "MLKInterpretedClosure.h"
 #import "MLKCons.h"
 #import "MLKDynamicContext.h"
 #import "MLKEnvironment.h"
@@ -51,6 +52,7 @@ static MLKSymbol *QUOTE;
 static MLKSymbol *SETQ;
 static MLKSymbol *PROGV;
 static MLKSymbol *_DEFMACRO;
+static MLKSymbol *_LAMBDA;
 
 
 @implementation MLKInterpreter
@@ -74,6 +76,7 @@ static MLKSymbol *_DEFMACRO;
   SETQ = [cl intern:@"SETQ"];
   PROGV = [cl intern:@"PROGV"];
   _DEFMACRO = [sys intern:@"%DEFMACRO"];
+  _LAMBDA = [sys intern:@"%LAMBDA"];
 }
 
 
@@ -128,6 +131,23 @@ static MLKSymbol *_DEFMACRO;
                                                         ? (id)[rest array]
                                                         : (id)[NSArray array])];
             }
+          else if (car == _DEFMACRO)
+            {
+              // No real lambda lists here.  This SYS::%DEFMACRO is
+              // really as low-level as it gets.
+              id name = [[program cdr] car];
+              id lambdaListAndBody = [[program cdr] cdr];
+
+              id <MLKFuncallable> function;
+
+              function = [self eval:[MLKCons cons:_LAMBDA with:lambdaListAndBody]
+                               inLexicalContext:context
+                               withEnvironment:lexenv];
+
+              [context addMacro:function forSymbol:name];
+
+              return name;
+            }
           else if (car == EVAL)
             {
               return [self eval:[self eval:[program cdr]
@@ -137,6 +157,22 @@ static MLKSymbol *_DEFMACRO;
                            withEnvironment:[MLKLexicalEnvironment
                                              globalEnvironment]];
             }
+          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] cdr];
+              MLKInterpretedClosure *closure;
+
+              closure = AUTORELEASE ([[MLKInterpretedClosure alloc]
+                                       initWithBodyForm:body
+                                       lambdaListName:lambdaList
+                                       context:context
+                                       environment:lexenv]);
+              return closure;
+            }
           else if (car == LET)
             {
               id declarations;
diff --git a/MLKLexicalContext.h b/MLKLexicalContext.h
index 2bf2bc4..552e77d 100644
--- a/MLKLexicalContext.h
+++ b/MLKLexicalContext.h
@@ -16,12 +16,13 @@
  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#import "MLKFuncallable.h"
 #import "MLKLispValue.h"
 
 #import <Foundation/NSSet.h>
 
 @class MLKEnvironment, MLKLexicalEnvironment, MLKSymbol, NSLinkedList, NSSet,
-       NSMutableDictionary, NSString, MLKCons, MLKFuncallable;
+       NSMutableDictionary, NSString, MLKCons;
 
 
 @interface MLKLexicalContext : MLKLispValue
@@ -47,6 +48,14 @@
                          symbolMacros:(NSDictionary *)symbolMacros
                          declarations:(id)declarations;
 
++(MLKLexicalContext *) contextWithParent:(MLKLexicalContext *)aContext
+                               variables:(NSSet *)vars
+                               functions:(NSSet *)functions
+                                  goTags:(NSDictionary *)goTags
+                                  macros:(NSDictionary *)macros
+                            symbolMacros:(NSDictionary *)symbolMacros
+                            declarations:(id)declarations;
+
 +(MLKLexicalContext *) globalContext;
 
 -(BOOL) symbolNamesFunction:(MLKSymbol *)symbol;
@@ -54,10 +63,11 @@
 -(BOOL) symbolNamesSymbolMacro:(MLKSymbol *)symbol;
 
 -(id) macroForSymbol:(MLKSymbol *)symbol;
--(void) setMacro:(MLKFuncallable *)function forSymbol:(MLKSymbol *)symbol;
+-(void) setMacro:(id <MLKFuncallable>)function forSymbol:(MLKSymbol *)symbol;
+-(void) addMacro:(id <MLKFuncallable>)value forSymbol:(MLKSymbol *)symbol;
 
 -(id) symbolMacroForSymbol:(MLKSymbol *)symbol;
--(void) setSymbolMacro:(MLKFuncallable *)function forSymbol:(MLKSymbol *)symbol;
+-(void) setSymbolMacro:(id <MLKFuncallable>)function forSymbol:(MLKSymbol *)symbol;
 
 -(id) goTagForSymbol:(MLKSymbol *)symbol;
 
diff --git a/MLKLexicalContext.m b/MLKLexicalContext.m
index 85539f1..32c1bf2 100644
--- a/MLKLexicalContext.m
+++ b/MLKLexicalContext.m
@@ -101,6 +101,24 @@ static MLKSymbol *LEXICAL;
   return self;  
 }
 
++(MLKLexicalContext *) contextWithParent:(MLKLexicalContext *)context
+                               variables:(NSSet *)vars
+                               functions:(NSSet *)functions
+                                  goTags:(NSDictionary *)goTags
+                                  macros:(NSDictionary *)macros
+                            symbolMacros:(NSDictionary *)symbolMacros
+                            declarations:(id)declarations
+{
+  return AUTORELEASE ([[self alloc]
+                        initWithParent:context
+                        variables:vars
+                        functions:functions
+                        goTags:goTags
+                        macros:macros
+                        symbolMacros:symbolMacros
+                        declarations:declarations]);
+}
+
 +(MLKLexicalContext *) globalContext
 {
   return global_context;
@@ -111,7 +129,12 @@ static MLKSymbol *LEXICAL;
   return [_macros valueForSymbol:symbol];
 }
 
--(void) setMacro:(MLKFuncallable *)value forSymbol:(MLKSymbol *)symbol
+-(void) addMacro:(id <MLKFuncallable>)value forSymbol:(MLKSymbol *)symbol
+{
+  [_symbolMacros addValue:value forSymbol:symbol];
+}
+
+-(void) setMacro:(id <MLKFuncallable>)value forSymbol:(MLKSymbol *)symbol
 {
   [_symbolMacros setValue:value forSymbol:symbol];
 }
@@ -121,7 +144,7 @@ static MLKSymbol *LEXICAL;
   return [_symbolMacros valueForSymbol:symbol];
 }
 
--(void) setSymbolMacro:(MLKFuncallable *)value forSymbol:(MLKSymbol *)symbol
+-(void) setSymbolMacro:(id <MLKFuncallable>)value forSymbol:(MLKSymbol *)symbol
 {
   [_symbolMacros setValue:value forSymbol:symbol];
 }
diff --git a/MLKLexicalEnvironment.h b/MLKLexicalEnvironment.h
index b8efed3..a97d5b9 100644
--- a/MLKLexicalEnvironment.h
+++ b/MLKLexicalEnvironment.h
@@ -33,7 +33,11 @@
   
 -(MLKLexicalEnvironment *) initWithParent:(MLKLexicalEnvironment *)aContext
                                 variables:(NSDictionary *)vars
-                                functions:(NSDictionary *)handlers;
+                                functions:(NSDictionary *)functions;
+
++(MLKLexicalEnvironment *) environmentWithParent:(MLKLexicalEnvironment *)context
+                                       variables:(NSDictionary *)vars
+                                       functions:(NSDictionary *)functions;
 
 +(MLKLexicalEnvironment *) globalEnvironment;
 
diff --git a/MLKLexicalEnvironment.m b/MLKLexicalEnvironment.m
index 66d5cb2..61f09c2 100644
--- a/MLKLexicalEnvironment.m
+++ b/MLKLexicalEnvironment.m
@@ -68,15 +68,24 @@ static MLKLexicalEnvironment *global_environment;
 
 -(MLKLexicalEnvironment *) initWithParent:(MLKLexicalEnvironment *)aContext
                                 variables:(NSDictionary *)vars
-                                functions:(NSDictionary *)handlers
+                                functions:(NSDictionary *)functions
 {
   self = [super init];
   ASSIGN (_parent, (aContext ? aContext : global_environment));
   _variables = MAKE_ENVIRONMENT(vars, _parent, _parent->_variables);
-  _functions = MAKE_ENVIRONMENT(handlers, _parent, _parent->_functions);
+  _functions = MAKE_ENVIRONMENT(functions, _parent, _parent->_functions);
   return self;
 }
 
++(MLKLexicalEnvironment *) environmentWithParent:(MLKLexicalEnvironment *)context
+                                       variables:(NSDictionary *)vars
+                                       functions:(NSDictionary *)functions
+{
+  return AUTORELEASE ([[self alloc] initWithParent:context
+                                    variables:vars
+                                    functions:functions]);
+}
+
 +(MLKLexicalEnvironment *) globalEnvironment
 {
   return global_environment;
diff --git a/MLKPackage.m b/MLKPackage.m
index 79e4182..4060e81 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -51,17 +51,31 @@ static NSMutableDictionary *packages = nil;
 
   [MLKPackage packageWithName:@"KEYWORD" nicknames:[NSSet set]];
 
-  [tlUser usePackage:toilet];
   [tlUser usePackage:cl];
+  [tlUser usePackage:toilet];
+
   [clUser usePackage:cl];
-  
+  [clUser usePackage:toilet];
+  [clUser usePackage:sys];
+
   [cl import:nil];
   [cl export:nil];
   [cl export:[cl intern:@"T"]];
+  [cl export:[cl intern:@"IF"]];
+  [cl export:[cl intern:@"LET"]];
+  [cl export:[cl intern:@"LAMBDA"]];
+  [cl export:[cl intern:@"FUNCALL"]];
+  [cl export:[cl intern:@"PROGN"]];
+  [cl export:[cl intern:@"APPLY"]];
+  [cl export:[cl intern:@"PROGV"]];
+  [cl export:[cl intern:@"SETQ"]];
+  [cl export:[cl intern:@"DECLARE"]];
+  [cl export:[cl intern:@"QUOTE"]];
+
+  [sys export:[sys intern:@"%DEFMACRO"]];
+  [sys export:[sys intern:@"%LAMBDA"]];
 
-  [sys intern:@"%DEFMACRO"];
   [tlUser usePackage:clUser];
-  [cl export:[cl intern:@"IF"]];
 }
 
 -(MLKPackage *) initWithName:(NSString *)name