From d86ccf58d5b462100d1f4ec5d016024543ec7f53 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 17 Aug 2008 22:43:25 +0200
Subject: Replace special operator %DEFMACRO with intrinsic function %MACROSET.

---
 MLKForm.h        |  8 --------
 MLKForm.m        | 26 --------------------------
 MLKInterpreter.m | 40 ----------------------------------------
 MLKPackage.m     |  2 +-
 MLKRoot.m        | 11 +++++++++++
 util.lisp        | 11 +++++++++++
 6 files changed, 23 insertions(+), 75 deletions(-)

diff --git a/MLKForm.h b/MLKForm.h
index bf7c41b..5263dbd 100644
--- a/MLKForm.h
+++ b/MLKForm.h
@@ -134,14 +134,6 @@
 @end
 
 
-@interface MLKSimpleDefmacroForm : MLKDeclaringForm
-{
-  MLKSymbol *_lambdaListName;
-  MLKSymbol *_name;
-}
-@end
-
-
 @interface MLKEvalWhenForm : MLKBodyForm
 {
   BOOL _compileToplevel;
diff --git a/MLKForm.m b/MLKForm.m
index 19e04ac..b255cc9 100644
--- a/MLKForm.m
+++ b/MLKForm.m
@@ -130,7 +130,6 @@
 
   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];
@@ -332,31 +331,6 @@
 @end
 
 
-@implementation MLKSimpleDefmacroForm
--(id) complete
-{
-  MLKLexicalContext *newContext;
-
-  self = [super complete];
-
-  LASSIGN (_name, [_tail car]);
-  LASSIGN (_lambdaListName, [[_tail cdr] car]);
-  newContext = [MLKLexicalContext contextWithParent:_context
-                                          variables:[NSSet setWithObject:_lambdaListName]
-                                          functions:nil
-                                             goTags:nil
-                                             macros:nil
-                                     compilerMacros:nil
-                                       symbolMacros:nil
-                                       declarations:[self declarationsWithForms:[[_tail cdr] cdr]]];
-
-  [self processBody:[[_tail cdr] cdr]
-          inContext:newContext];
-  return self;
-}
-@end
-
-
 @implementation MLKEvalWhenForm
 -(id) complete
 {
diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index 21adaea..3f91814 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -289,46 +289,6 @@
 
               return nil;
             }
-          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;
-
-              if (expandOnly)
-                {
-                  id lambdaList = [lambdaListAndBody car];
-                  id body = [lambdaListAndBody cdr];
-                  id body_expansion =
-                    denullify([[self eval:[MLKCons cons:PROGN with:body]
-                                     inLexicalContext:context
-                                     withEnvironment:lexenv
-                                     expandOnly:expandOnly]
-                                objectAtIndex:0]);
-                  RETURN_VALUE ([MLKCons
-                                  cons:_DEFMACRO
-                                  with:[MLKCons
-                                         cons:name
-                                         with:[MLKCons
-                                                cons:lambdaList
-                                                with:[MLKCons
-                                                       cons:body_expansion
-                                                       with:nil]]]]);
-                }
-
-              function = denullify([[self eval:[MLKCons cons:_LAMBDA with:lambdaListAndBody]
-                                          inLexicalContext:context
-                                          withEnvironment:lexenv
-                                          expandOnly:expandOnly]
-                                     objectAtIndex:0]);
-
-              [context addMacro:function forSymbol:name];
-
-              RETURN_VALUE (name);
-            }
           else if (car == EVAL)
             {
               NSArray *evaluand = denullify([[self eval:[[program cdr] car]
diff --git a/MLKPackage.m b/MLKPackage.m
index 9bae8fe..c86f8a6 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -105,10 +105,10 @@ static NSMutableDictionary *packages = nil;
   [cl export:[cl intern:@"MULTIPLE-VALUE-CALL"]];
   [cl export:[cl intern:@"EVAL-WHEN"]];
 
-  [sys export:[sys intern:@"%DEFMACRO"]];
   [sys export:[sys intern:@"%LAMBDA"]];
   [sys export:[sys intern:@"%FSET"]];
   [sys export:[sys intern:@"%FSETQ"]];
+  [sys export:[sys intern:@"%MACROSET"]];
   [sys export:[sys intern:@"%LOOP"]];
   [sys export:[sys intern:@"%FLET"]];
   [sys export:[sys intern:@"%MACROLET"]];
diff --git a/MLKRoot.m b/MLKRoot.m
index 0c59c23..b12cd17 100644
--- a/MLKRoot.m
+++ b/MLKRoot.m
@@ -746,4 +746,15 @@ as provided by method %@ of object %@",
 
   RETURN_VALUE (value);
 }
+
++(NSArray *) macroset:(NSArray *)args
+{
+  id symbol = denullify ([args objectAtIndex:0]);
+  id value = denullify ([args objectAtIndex:1]);
+
+  [[MLKLexicalContext globalContext] addMacro:value
+                                     forSymbol:symbol];
+
+  RETURN_VALUE (value);
+}
 @end
diff --git a/util.lisp b/util.lisp
index 412b23d..ede7eeb 100644
--- a/util.lisp
+++ b/util.lisp
@@ -22,6 +22,17 @@
           otherwise unless when eq boundp))
 
 
+(%macroset '%defmacro
+           (%lambda args
+             (let ((form (car args)))
+               (let ((name (car (cdr form)))
+                     (lambda-list-name (car (cdr (cdr form))))
+                     (body (cdr (cdr (cdr form)))))
+                 (list '%macroset
+                       (list 'quote name)
+                       (cons '%lambda
+                             (cons lambda-list-name body)))))))
+
 (%defmacro %defun args
   (list '%fset
         (list 'quote (car (cdr (car args))))
-- 
cgit v1.2.3