From c802172ab92da89a8e9a8cc92c47c09f222dacd1 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 10 Aug 2008 12:17:53 +0200
Subject: Add class cluster MLKForm.
---
GNUmakefile | 2 +-
MLKForm.m | 209 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
MLKInterpreter.m | 90 +----------------------
special-symbols.h | 114 +++++++++++++++++++++++++++++
4 files changed, 326 insertions(+), 89 deletions(-)
create mode 100644 MLKForm.m
create mode 100644 special-symbols.h
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"];
+}
--
cgit v1.2.3