Reader: Support quasiquotation.

8 files changed, 253 insertions, 16 deletions

diff --git a/GNUmakefile b/GNUmakefile
index 3ba767b..143598a 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -27,18 +27,19 @@ BUNDLE_NAME = Test
 
 ADDITIONAL_OBJCFLAGS = -Wall
 
-ToiletKit_OBJC_FILES = MLKCharacter.m MLKCons.m MLKBinding.m			\
-                       MLKDoubleFloat.m MLKDynamicContext.m			\
-                       MLKEnvironment.m MLKFloat.m MLKInteger.m			\
-                       MLKInterpretedClosure.m MLKInterpreter.m			\
-                       MLKLinkedList.m MLKLexicalContext.m			\
-                       MLKLexicalEnvironment.m MLKLispValue.m			\
-                       MLKNumber.m MLKPackage.m MLKParenReader.m		\
-                       MLKQuoteReader.m MLKRatio.m MLKReader.m			\
-                       MLKReadtable.m MLKReaderError.m MLKRoot.m		\
-                       MLKSemicolonReader.m MLKSingleFloat.m MLKStream.m	\
-                       MLKStringInputStream.m MLKStringOutputStream.m		\
-                       MLKStringReader.m MLKSymbol.m MLKThrowException.m	\
+ToiletKit_OBJC_FILES = MLKCharacter.m MLKCons.m MLKBackquoteReader.m	\
+                       MLKBinding.m MLKCommaReader.m MLKDoubleFloat.m	\
+                       MLKDynamicContext.m MLKEnvironment.m MLKFloat.m	\
+                       MLKInteger.m MLKInterpretedClosure.m		\
+                       MLKInterpreter.m MLKLinkedList.m			\
+                       MLKLexicalContext.m MLKLexicalEnvironment.m	\
+                       MLKLispValue.m MLKNumber.m MLKPackage.m		\
+                       MLKParenReader.m MLKQuoteReader.m MLKRatio.m	\
+                       MLKReader.m MLKReadtable.m MLKReaderError.m	\
+                       MLKRoot.m MLKSemicolonReader.m MLKSingleFloat.m	\
+                       MLKStream.m MLKStringInputStream.m		\
+                       MLKStringOutputStream.m MLKStringReader.m	\
+                       MLKSymbol.m MLKThrowException.m			\
                        NSObject-MLKPrinting.m NSString-MLKPrinting.m
 ToiletKit_LDFLAGS = -lgmp
 #LIBRARIES_DEPEND_UPON
diff --git a/MLKBackquoteReader.h b/MLKBackquoteReader.h
new file mode 100644
index 0000000..1c35bfa
--- /dev/null
+++ b/MLKBackquoteReader.h
@@ -0,0 +1,27 @@
+/* -*- 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 <Foundation/NSArray.h>
+
+
+@interface MLKBackquoteReader : MLKLispValue <MLKFuncallable>
+-(NSArray *) applyToArray:(NSArray *)arguments;
+@end
diff --git a/MLKBackquoteReader.m b/MLKBackquoteReader.m
new file mode 100644
index 0000000..47989ab
--- /dev/null
+++ b/MLKBackquoteReader.m
@@ -0,0 +1,62 @@
+/* -*- 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 "MLKBackquoteReader.h"
+
+#import "MLKCons.h"
+#import "MLKDynamicContext.h"
+#import "MLKReader.h"
+#import "MLKReadtable.h"
+#import "MLKPackage.h"
+#import "MLKStream.h"
+#import "runtime-compatibility.h"
+#import "util.h"
+
+
+@implementation MLKBackquoteReader
+-(NSArray *) applyToArray:(NSArray *)arguments
+{
+  MLKStream *stream;
+  MLKReadtable *readtable;
+  MLKPackage *cl, *sys;
+  unichar ch;
+  id quoted_form;
+
+  cl = [MLKPackage findPackage:@"COMMON-LISP"];
+  sys = [MLKPackage findPackage:@"TOILET-SYSTEM"];
+
+  stream = [arguments objectAtIndex:0];
+  readtable = [[MLKDynamicContext currentContext]
+                valueForSymbol:[cl intern:@"*READTABLE*"]];
+
+  while ([readtable isWhitespaceCharacter:(ch = [stream readChar])]);
+
+  [stream unreadChar:ch];
+
+  quoted_form = [MLKReader readFromStream:stream
+                           eofError:YES
+                           eofValue:nil
+                           recursive:YES
+                           preserveWhitespace:NO];
+
+  return [NSArray arrayWithObject:
+                    [MLKCons cons:[sys intern:@"QUASIQUOTE"]
+                             with:[MLKCons cons:nullify(quoted_form)
+                                           with:nil]]];
+}
+@end
diff --git a/MLKCommaReader.h b/MLKCommaReader.h
new file mode 100644
index 0000000..5f5d11e
--- /dev/null
+++ b/MLKCommaReader.h
@@ -0,0 +1,27 @@
+/* -*- 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 <Foundation/NSArray.h>
+
+
+@interface MLKCommaReader : MLKLispValue <MLKFuncallable>
+-(NSArray *) applyToArray:(NSArray *)arguments;
+@end
diff --git a/MLKCommaReader.m b/MLKCommaReader.m
new file mode 100644
index 0000000..3a0115b
--- /dev/null
+++ b/MLKCommaReader.m
@@ -0,0 +1,73 @@
+/* -*- 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 "MLKCommaReader.h"
+
+#import "MLKCons.h"
+#import "MLKDynamicContext.h"
+#import "MLKReader.h"
+#import "MLKReadtable.h"
+#import "MLKPackage.h"
+#import "MLKStream.h"
+#import "runtime-compatibility.h"
+#import "util.h"
+
+
+@implementation MLKCommaReader
+-(NSArray *) applyToArray:(NSArray *)arguments
+{
+  MLKStream *stream;
+  MLKReadtable *readtable;
+  MLKPackage *cl, *sys;
+  MLKSymbol *marker;
+  unichar ch;
+  id quoted_form;
+
+  cl = [MLKPackage findPackage:@"COMMON-LISP"];
+  sys = [MLKPackage findPackage:@"TOILET-SYSTEM"];
+
+  stream = [arguments objectAtIndex:0];
+  readtable = [[MLKDynamicContext currentContext]
+                valueForSymbol:[cl intern:@"*READTABLE*"]];
+
+  if ((ch = [stream readChar]) == '@')
+    {
+      marker = [sys intern:@"UNQUOTE-SPLICING"];
+    }
+  else
+    {
+      marker = [sys intern:@"UNQUOTE"];
+      [stream unreadChar:ch];
+    }
+
+  while ([readtable isWhitespaceCharacter:(ch = [stream readChar])]);
+
+  [stream unreadChar:ch];
+
+  quoted_form = [MLKReader readFromStream:stream
+                           eofError:YES
+                           eofValue:nil
+                           recursive:YES
+                           preserveWhitespace:NO];
+
+  return [NSArray arrayWithObject:
+                    [MLKCons cons:marker
+                             with:[MLKCons cons:nullify(quoted_form)
+                                           with:nil]]];
+}
+@end
diff --git a/MLKDynamicContext.m b/MLKDynamicContext.m
index 593f4a7..1b8725b 100644
--- a/MLKDynamicContext.m
+++ b/MLKDynamicContext.m
@@ -24,6 +24,8 @@
 #import <Foundation/NSString.h>
 #import <Foundation/NSThread.h>
 
+#import "MLKBackquoteReader.h"
+#import "MLKCommaReader.h"
 #import "MLKCons.h"
 #import "MLKDynamicContext.h"
 #import "MLKEnvironment.h"
@@ -147,8 +149,6 @@ static MLKDynamicContext *global_context;
   [readtable setSyntaxType:MULTI_ESCAPE forCharacter:'|'];
 
   //  [readtable setSyntaxType:NONTERMINATING_MACRO forCharacter:'#'];
-  //  [readtable setSyntaxType:TERMINATING_MACRO forCharacter:'`'];
-  //  [readtable setSyntaxType:TERMINATING_MACRO forCharacter:','];
 
   [readtable setSyntaxType:SINGLE_ESCAPE forCharacter:'\\'];
   
@@ -164,6 +164,14 @@ static MLKDynamicContext *global_context;
   [readtable setSyntaxType:TERMINATING_MACRO forCharacter:'\''];
   [readtable setMacroFunction:AUTORELEASE([[MLKQuoteReader alloc] init])
              forCharacter:'\''];
+  
+  [readtable setSyntaxType:TERMINATING_MACRO forCharacter:'`'];
+  [readtable setMacroFunction:AUTORELEASE([[MLKBackquoteReader alloc] init])
+             forCharacter:'`'];
+  
+  [readtable setSyntaxType:TERMINATING_MACRO forCharacter:','];
+  [readtable setMacroFunction:AUTORELEASE([[MLKCommaReader alloc] init])
+             forCharacter:','];
 
   [readtable setSyntaxType:TERMINATING_MACRO forCharacter:';'];
   [readtable setMacroFunction:AUTORELEASE([[MLKSemicolonReader alloc] init])
diff --git a/MLKRoot.m b/MLKRoot.m
index dc2560d..d007173 100644
--- a/MLKRoot.m
+++ b/MLKRoot.m
@@ -225,10 +225,12 @@ static id truify (BOOL value)
 +(NSArray *) macroexpand_1:(NSArray *)args
 {
   id form = [args objectAtIndex:0];
-  id env = [args count] > 1 ? [args objectAtIndex:1] : nil;
+  id env = [args count] > 1 ? denullify([args objectAtIndex:1]) : nil;
   MLKLexicalContext *context = env ? (id)env : (id)[MLKLexicalContext globalContext];
 
-  if ([context symbolNamesMacro:[form car]])
+  if ([form isKindOfClass:[MLKCons class]]
+      && (![form car] || [[form car] isKindOfClass:[MLKSymbol class]])
+      && [context symbolNamesMacro:[form car]])
     {
       id <MLKFuncallable> macrofun = [context macroForSymbol:[form car]];
       form = denullify ([[macrofun applyToArray:
diff --git a/util.lisp b/util.lisp
index 50688a3..ca1b25a 100644
--- a/util.lisp
+++ b/util.lisp
@@ -134,3 +134,40 @@
                                   (list 'quote (car this-clause))))
                         (cons 'progn (cdr this-clause))
                         (list* 'case object-sym rest)))))))
+
+(%defmacro* sys::quasiquote (object)
+  (if (not (consp object))
+      (list 'quote object)
+      (cond ((eq 'sys::unquote (car object)) (car (cdr object)))
+            ((eq 'sys::quasiquote (car object)) (list 'quote object))
+            ((and (consp (car object))
+                  (eq 'sys::unquote-splicing (car (car object))))
+             (list 'append
+                   (car (cdr (car object)))
+                   (list 'sys::quasiquote (cdr object))))
+            (t (list 'cons
+                     (list 'sys::quasiquote (car object))
+                     (list 'sys::quasiquote (cdr object)))))))
+
+(%defun* list-eqp (list1 list2)
+  "Not really EQUALP (only works on trees of symbols)."
+  (if (and (consp list1) (consp list2))
+      (and (list-eqp (car list1) (car list2))
+           (list-eqp (cdr list1) (cdr list2)))
+      (eq list1 list2)))
+
+(%defun* macroexpand (object . rest)
+  (let* ((env (if rest (car rest) nil))
+         (expansion-1 (macroexpand-1 object env))
+         (expansion-2 (macroexpand-1 expansion-1 env)))
+    (if (list-eqp expansion-1 expansion-2)
+        expansion-1
+        (macroexpand expansion-2))))
+
+(%defun* macroexpand-all (object . rest)
+  (let* ((env (if rest (car rest) nil)))
+    (if (consp object)
+        (let ((expansion (macroexpand object env)))
+          (cons (macroexpand-all (car expansion))
+                (macroexpand-all (cdr expansion))))
+        object)))