From fae93c68ddb1c7cbc800f0d17eea8f2bb103a281 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Thu, 31 Jul 2008 14:26:13 +0200
Subject: Add %MACROLET.

---
 MLKInterpreter.m | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 MLKPackage.m     |  1 +
 2 files changed, 74 insertions(+)

diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index 8267880..718df93 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -50,6 +50,7 @@ static MLKSymbol *TAGBODY;
 static MLKSymbol *GO;
 static MLKSymbol *CATCH;
 static MLKSymbol *THROW;
+static MLKSymbol *_MACROLET;
 static MLKSymbol *LAMBDA;
 static MLKSymbol *LET;
 static MLKSymbol *APPLY;
@@ -85,6 +86,7 @@ static MLKSymbol *_LOOP;
   THROW = [cl intern:@"THROW"];
   LAMBDA = [cl intern:@"LAMBDA"];
   LET = [cl intern:@"LET"];
+  _MACROLET = [sys intern:@"%MACROLET"];
   _LOOP = [sys intern:@"%LOOP"];
   APPLY = [cl intern:@"APPLY"];
   EVAL = [cl intern:@"EVAL"];
@@ -439,6 +441,77 @@ static MLKSymbol *_LOOP;
                                        environment:lexenv]);
               return [NSArray arrayWithObject:nullify(closure)];
             }
+          else if (car == _MACROLET)
+            {
+              id declarations;
+              id clauses;
+              id body;
+              NSArray *result;
+              MLKLexicalContext *ctx;
+
+              body = [[program cdr] cdr];
+
+              if ([[body car] isKindOfClass:[MLKCons class]]
+                  && [[body car] car] == DECLARE)
+                {
+                  declarations = [[body car] cdr];
+                  body = [body cdr];
+                }
+              else
+                {
+                  declarations = nil;
+                }
+
+              ctx = AUTORELEASE ([[MLKLexicalContext alloc]
+                                   initWithParent:context
+                                   variables:nil
+                                   functions:nil
+                                   goTags:nil
+                                   macros:nil
+                                   compilerMacros:nil
+                                   symbolMacros:nil
+                                   declarations:declarations]);
+
+              clauses = [[program cdr] car];
+              while (clauses)
+                {
+                  id clause = [clauses car];
+                  id name, value;
+
+                  name = [clause car];
+                  value = denullify([[self eval:[MLKCons cons:_LAMBDA
+                                                         with:[clause cdr]]
+                                           inLexicalContext:context
+                                           withEnvironment:lexenv
+                                           expandOnly:NO]  //!
+                                      objectAtIndex:0]);
+
+                  [ctx addMacro:value forSymbol:name];
+
+                  clauses = [clauses cdr];
+                }
+
+              result = [self eval:[MLKCons cons:PROGN with:body]
+                             inLexicalContext:ctx
+                             withEnvironment:lexenv
+                             expandOnly:expandOnly];
+
+              if (expandOnly)
+                {
+                  RETURN_VALUE ([MLKCons
+                                  cons:LET
+                                  with:[MLKCons
+                                         cons:nil
+                                         with:[MLKCons
+                                                cons:[MLKCons cons:DECLARE
+                                                              with:declarations]
+                                                with:[[result objectAtIndex:0] cdr]]]);
+                }
+              else
+                {
+                  return result;
+                }
+            }
           else if (car == LET)
             {
               id declarations;
diff --git a/MLKPackage.m b/MLKPackage.m
index 3153b74..d3cadd7 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -92,6 +92,7 @@ static NSMutableDictionary *packages = nil;
   [sys export:[sys intern:@"%LAMBDA"]];
   [sys export:[sys intern:@"%FSET"]];
   [sys export:[sys intern:@"%LOOP"]];
+  [sys export:[sys intern:@"%MACROLET"]];
 
   [sys export:[sys intern:@"CAR"]];
   [sys export:[sys intern:@"CDR"]];
-- 
cgit v1.2.3