Add class cluster MLKForm.

4 files changed, 326 insertions, 89 deletions

diff --git a/GNUmakefile b/GNUmakefile
index cff81a7..3f7ae93 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -53,7 +53,7 @@ ToiletKit_OBJC_FILES = functions.m globals.m MLKArray.m				\
                        MLKDoubleFloat.m						\
                        MLKDispatchingMacroCharacterReader.m			\
                        MLKDynamicContext.m MLKEnvironment.m MLKFloat.m		\
-                       MLKForeignProcedure.m MLKInteger.m			\
+                       MLKForeignProcedure.m MLKForm.m MLKInteger.m		\
                        MLKInterpretedClosure.m MLKInterpreter.m			\
                        MLKLexicalContext.m MLKLexicalEnvironment.m		\
                        MLKLispValue.m MLKNumber.m MLKPackage.m			\
diff --git a/MLKForm.m b/MLKForm.m
new file mode 100644
index 0000000..6e8bed5
--- /dev/null
+++ b/MLKForm.m
@@ -0,0 +1,209 @@
+/* -*- mode: objc; coding: utf-8 -*- */
+/* Toilet Lisp, 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 "MLKForm.h"
+#import "util.h"
+#import "special-symbols.h"
+
+#import <Foundation/NSString.h>
+
+
+@implementation MLKForm
+-(void) initialize
+{
+  ensure_symbols ();
+}
+
+-(id) initWithObject:(id)object
+           inContext:(MLKLexicalContext *)context
+         forCompiler:(id)compiler
+{
+  _form = object;
+  _context = context;
+  _compiler = compiler;
+  return [self complete];
+}
+
+-(id) complete
+{
+  return self;
+}
+
++(Class) dispatchClassForObject:(id)object
+{
+  if ([object isKindOfClass:[MLKCons class]])
+    return [MLKCompoundForm class];
+  else
+    return [MLKAtomicForm class];
+}
+
++(id) formWithObject:(id)object
+           inContext:(MLKLexicalContext *)context
+         forCompiler:(id)compiler
+{
+  Class cls = [self dispatchClassForObject:object];
+                
+  if (cls != self)
+    return [cls formWithObject:object
+                inContext:context
+                forCompiler:compiler];
+  else
+    return LAUTORELEASE ([[self alloc]
+                           initWithObject:object
+                           inContext:context
+                           forCompiler:compiler]);
+}
+@end
+
+
+@implementation MLKAtomicForm
++(Class) dispatchClassForObject:(id)object
+{
+  if ([object isKindOfClass:[MLKSymbol class]])
+    return [MLKSymbolForm class];
+  else
+    return [MLKSelfEvaluatingForm class];
+}
+@end
+
+
+@implementation MLKSelfEvaluatingForm
+// FIXME
+
++(Class) dispatchClassForObject:(id)object
+{
+  return self;
+}
+@end
+
+
+@implementation MLKSymbolForm
+// FIXME
+
++(Class) dispatchClassForObject:(id)object
+{
+  return self;
+}
+@end
+
+
+@implementation MLKCompoundForm
+-(id) complete
+{
+  self = [super complete];
+  _head = [_form car];
+  _tail = [_form cdr];
+  return self;
+}
+
++(Class) dispatchClassForObject:(id)object
+{
+  id car = [object car];
+
+  if (car == APPLY) return [MLKFunctionCallForm class];
+  else if (car == CATCH) return [MLKCatchForm class];
+  else if (car == _DEFMACRO) return [MLKSimpleDefmacroForm class];
+  else if (car == EVAL) return [MLKFunctionCallForm class];
+  else if (car == EVAL_WHEN) return [MLKEvalWhenForm class];
+  else if (car == _FOREIGN_LAMBDA) return [MLKForeignLambdaForm class];
+  else if (car == FUNCTION) return [MLKFunctionForm class];
+  else if (car == IF) return [MLKIfForm class];
+  else if (car == IN_PACKAGE) return [MLKInPackageForm class];
+  else if (car == _LAMBDA) return [MLKSimpleLambdaForm class];
+  else if (car == _MACROLET) return [MLKSimpleMacroletForm class];
+  else if (car == _FLET) return [MLKSimpleFletForm class];
+  else if (car == LET) return [MLKLetForm class];
+  else if (car == _LOOP) return [MLKSimpleLoopForm class];
+  else if (car == MULTIPLE_VALUE_CALL) return [MLKMultipleValueCallForm class];
+  else if (car == PROGN) return [MLKProgNForm class];
+  else if (car == PROGV) return [MLKProgVForm class];
+  else if (car == QUOTE) return [MLKQuoteForm class];
+  else if (car == SETQ) return [MLKSetQForm class];
+  else if (car == _FSETQ) return [MLKFSetQForm class];
+  else if (car == SET) return [MLKSetForm class];
+  else if (car == _FSET) return [MLKFSetForm class];
+  else if (car == THROW) return [MLKThrowForm class];
+  else if (car == UNWIND_PROTECT) return [MLKUnwindProtectForm class];
+  else return [MLKSimpleCompoundForm class];
+}
+@end
+
+
+@implementation MLKSimpleCompoundForm
+-(id) initWithObject:(id)object
+           inContext:(MLKLexicalContext *)context
+         forCompiler:(id)compiler
+{
+  self = [super initWithObject:object
+                inContext:context
+                forCompiler:compiler];
+
+  if ([_head isKindOfClass:[MLKCons class]])
+    {
+      LRELEASE (self);
+      return [MLKForm formWithObject:[MLKCons cons:FUNCALL
+                                              with:object]
+                      inContext:context
+                      forCompiler:compiler];
+    }
+  else if ([context symbolNamesMacro:_head])
+    {
+      LRELEASE (self);
+      return [MLKMacroCallForm formWithObject:object
+                               inContext:context
+                               forCompiler:compiler];
+    }
+  else
+    {
+      LRELEASE (self);
+      return [MLKFunctionCallForm formWithObject:object
+                                  inContext:context
+                                  forCompiler:compiler];
+    }
+}
+
+
++(Class) dispatchClassForObject:(id)object
+{
+  return self;
+}
+@end
+
+
+@implementation MLKMacroCallForm : MLKSimpleCompoundForm
+-(id) initWithObject:(id)object
+           inContext:(MLKLexicalContext *)context
+         forCompiler:(id)compiler
+{
+  self = [super initWithObject:object
+                inContext:context
+                forCompiler:compiler];
+
+  id <MLKFuncallable> macrofun = [context macroForSymbol:_head];
+  id expansion = denullify ([[macrofun
+                               applyToArray:
+                                 [NSArray arrayWithObjects:
+                                            _form, context, nil]]
+                              objectAtIndex:0]);
+
+  return [MLKForm formWithObject:expansion
+                  inContext:context
+                  forCompiler:compiler];
+}
+@end
diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index deb92eb..d3d6161 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -35,6 +35,7 @@
 #import "MLKSymbol.h"
 #import "NSObject-MLKPrinting.h"
 #import "runtime-compatibility.h"
+#import "special-symbols.h"
 #import "util.h"
 
 #import <Foundation/NSArray.h>
@@ -56,97 +57,10 @@
 #endif
 
 
-static MLKPackage *cl;
-static MLKPackage *sys;
-static MLKPackage *keyword;
-static MLKSymbol *IF;
-static MLKSymbol *IN_PACKAGE;
-static MLKSymbol *DECLARE;
-static MLKSymbol *PROGN;
-static MLKSymbol *TAGBODY;
-static MLKSymbol *GO;
-static MLKSymbol *CATCH;
-static MLKSymbol *THROW;
-static MLKSymbol *_FLET;
-static MLKSymbol *_MACROLET;
-static MLKSymbol *LAMBDA;
-static MLKSymbol *LET;
-static MLKSymbol *LOCALLY;
-static MLKSymbol *APPLY;
-static MLKSymbol *FUNCALL;
-static MLKSymbol *FUNCTION;
-static MLKSymbol *EVAL;
-static MLKSymbol *EVAL_WHEN;
-static MLKSymbol *QUOTE;
-static MLKSymbol *SETQ;
-static MLKSymbol *SETF;
-static MLKSymbol *SET;
-static MLKSymbol *_FSETQ;
-static MLKSymbol *_FSET;
-static MLKSymbol *SYMBOL_MACROLET;
-static MLKSymbol *PROGV;
-static MLKSymbol *UNWIND_PROTECT;
-static MLKSymbol *VALUES;
-static MLKSymbol *_DEFMACRO;
-static MLKSymbol *_FOREIGN_LAMBDA;
-static MLKSymbol *_LAMBDA;
-static MLKSymbol *_LOOP;
-static MLKSymbol *V_INITP;
-static MLKSymbol *COMPILE_TOPLEVEL;
-static MLKSymbol *COMPILE;
-static MLKSymbol *LOAD_TOPLEVEL;
-static MLKSymbol *LOAD;
-static MLKSymbol *EXECUTE;
-static MLKSymbol *MULTIPLE_VALUE_CALL;
-
-
 @implementation MLKInterpreter
 +(void) initialize
 {
-  cl = [MLKPackage findPackage:@"COMMON-LISP"];
-  sys = [MLKPackage findPackage:@"TOILET-SYSTEM"];
-  keyword = [MLKPackage findPackage:@"KEYWORD"];
-
-  IF = [cl intern:@"IF"];
-  IN_PACKAGE = [cl intern:@"IN-PACKAGE"];
-  DECLARE = [cl intern:@"DECLARE"];
-  PROGN = [cl intern:@"PROGN"];
-  TAGBODY = [cl intern:@"TAGBODY"];
-  GO = [cl intern:@"GO"];
-  CATCH = [cl intern:@"CATCH"];
-  THROW = [cl intern:@"THROW"];
-  LAMBDA = [cl intern:@"LAMBDA"];
-  LET = [cl intern:@"LET"];
-  LOCALLY = [cl intern:@"LOCALLY"];
-  _FLET = [sys intern:@"%FLET"];
-  _MACROLET = [sys intern:@"%MACROLET"];
-  _LOOP = [sys intern:@"%LOOP"];
-  APPLY = [cl intern:@"APPLY"];
-  EVAL = [cl intern:@"EVAL"];
-  EVAL_WHEN = [cl intern:@"EVAL-WHEN"];
-  FUNCALL = [cl intern:@"FUNCALL"];
-  FUNCTION = [cl intern:@"FUNCTION"];
-  QUOTE = [cl intern:@"QUOTE"];
-  SETQ = [cl intern:@"SETQ"];
-  SETF = [cl intern:@"SETF"];
-  SET = [cl intern:@"SET"];
-  _FSETQ = [sys intern:@"%FSETQ"];
-  _FSET = [sys intern:@"%FSET"];
-  SYMBOL_MACROLET = [cl intern:@"SYMBOL-MACROLET"];
-  PROGV = [cl intern:@"PROGV"];
-  VALUES = [cl intern:@"VALUES"];
-  UNWIND_PROTECT = [cl intern:@"UNWIND-PROTECT"];
-  _DEFMACRO = [sys intern:@"%DEFMACRO"];
-  _FOREIGN_LAMBDA = [sys intern:@"%FOREIGN-LAMBDA"];
-  _LAMBDA = [sys intern:@"%LAMBDA"];
-  V_INITP = [sys intern:@"*SYSTEM-INITIALISED-P*"];
-  MULTIPLE_VALUE_CALL = [cl intern:@"MULTIPLE-VALUE-CALL"];
-
-  COMPILE_TOPLEVEL = [keyword intern:@"COMPILE-TOPLEVEL"];
-  COMPILE = [cl intern:@"COMPILE"];
-  LOAD_TOPLEVEL = [keyword intern:@"LOAD-TOPLEVEL"];
-  LOAD = [cl intern:@"LOAD"];
-  EXECUTE = [keyword intern:@"EXECUTE"];
+  ensure_symbols ();
 }
 
 
diff --git a/special-symbols.h b/special-symbols.h
new file mode 100644
index 0000000..2e80bf7
--- /dev/null
+++ b/special-symbols.h
@@ -0,0 +1,114 @@
+/* -*- mode: objc; coding: utf-8 -*- */
+/* Toilet Lisp, 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 "MLKSymbol.h"
+#import "MLKPackage.h"
+
+static MLKPackage *cl;
+static MLKPackage *sys;
+static MLKPackage *keyword;
+
+static MLKSymbol *IF;
+static MLKSymbol *IN_PACKAGE;
+static MLKSymbol *DECLARE;
+static MLKSymbol *PROGN;
+static MLKSymbol *TAGBODY;
+static MLKSymbol *GO;
+static MLKSymbol *CATCH;
+static MLKSymbol *THROW;
+static MLKSymbol *_FLET;
+static MLKSymbol *_MACROLET;
+static MLKSymbol *LAMBDA;
+static MLKSymbol *LET;
+static MLKSymbol *LOCALLY;
+static MLKSymbol *APPLY;
+static MLKSymbol *FUNCALL;
+static MLKSymbol *FUNCTION;
+static MLKSymbol *EVAL;
+static MLKSymbol *EVAL_WHEN;
+static MLKSymbol *QUOTE;
+static MLKSymbol *SETQ;
+static MLKSymbol *SETF;
+static MLKSymbol *SET;
+static MLKSymbol *_FSETQ;
+static MLKSymbol *_FSET;
+static MLKSymbol *SYMBOL_MACROLET;
+static MLKSymbol *PROGV;
+static MLKSymbol *UNWIND_PROTECT;
+static MLKSymbol *VALUES;
+static MLKSymbol *_DEFMACRO;
+static MLKSymbol *_FOREIGN_LAMBDA;
+static MLKSymbol *_LAMBDA;
+static MLKSymbol *_LOOP;
+static MLKSymbol *V_INITP;
+static MLKSymbol *COMPILE_TOPLEVEL;
+static MLKSymbol *COMPILE;
+static MLKSymbol *LOAD_TOPLEVEL;
+static MLKSymbol *LOAD;
+static MLKSymbol *EXECUTE;
+static MLKSymbol *MULTIPLE_VALUE_CALL;
+
+
+static void
+ensure_symbols ()
+{
+  cl = [MLKPackage findPackage:@"COMMON-LISP"];
+  sys = [MLKPackage findPackage:@"TOILET-SYSTEM"];
+  keyword = [MLKPackage findPackage:@"KEYWORD"];
+
+  IF = [cl intern:@"IF"];
+  IN_PACKAGE = [cl intern:@"IN-PACKAGE"];
+  DECLARE = [cl intern:@"DECLARE"];
+  PROGN = [cl intern:@"PROGN"];
+  TAGBODY = [cl intern:@"TAGBODY"];
+  GO = [cl intern:@"GO"];
+  CATCH = [cl intern:@"CATCH"];
+  THROW = [cl intern:@"THROW"];
+  LAMBDA = [cl intern:@"LAMBDA"];
+  LET = [cl intern:@"LET"];
+  LOCALLY = [cl intern:@"LOCALLY"];
+  _FLET = [sys intern:@"%FLET"];
+  _MACROLET = [sys intern:@"%MACROLET"];
+  _LOOP = [sys intern:@"%LOOP"];
+  APPLY = [cl intern:@"APPLY"];
+  EVAL = [cl intern:@"EVAL"];
+  EVAL_WHEN = [cl intern:@"EVAL-WHEN"];
+  FUNCALL = [cl intern:@"FUNCALL"];
+  FUNCTION = [cl intern:@"FUNCTION"];
+  QUOTE = [cl intern:@"QUOTE"];
+  SETQ = [cl intern:@"SETQ"];
+  SETF = [cl intern:@"SETF"];
+  SET = [cl intern:@"SET"];
+  _FSETQ = [sys intern:@"%FSETQ"];
+  _FSET = [sys intern:@"%FSET"];
+  SYMBOL_MACROLET = [cl intern:@"SYMBOL-MACROLET"];
+  PROGV = [cl intern:@"PROGV"];
+  VALUES = [cl intern:@"VALUES"];
+  UNWIND_PROTECT = [cl intern:@"UNWIND-PROTECT"];
+  _DEFMACRO = [sys intern:@"%DEFMACRO"];
+  _FOREIGN_LAMBDA = [sys intern:@"%FOREIGN-LAMBDA"];
+  _LAMBDA = [sys intern:@"%LAMBDA"];
+  V_INITP = [sys intern:@"*SYSTEM-INITIALISED-P*"];
+  MULTIPLE_VALUE_CALL = [cl intern:@"MULTIPLE-VALUE-CALL"];
+
+  COMPILE_TOPLEVEL = [keyword intern:@"COMPILE-TOPLEVEL"];
+  COMPILE = [cl intern:@"COMPILE"];
+  LOAD_TOPLEVEL = [keyword intern:@"LOAD-TOPLEVEL"];
+  LOAD = [cl intern:@"LOAD"];
+  EXECUTE = [keyword intern:@"EXECUTE"];
+}