From d4cea2c3033b37445a53730dc82630e14d443e0c Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Thu, 31 Jul 2008 15:47:52 +0200
Subject: Add %FLET and FLET.

---
 MLKInterpreter.m | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 88 insertions(+)

(limited to 'MLKInterpreter.m')

diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index 74a2fe1..5e11637 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 *_FLET;
 static MLKSymbol *_MACROLET;
 static MLKSymbol *LAMBDA;
 static MLKSymbol *LET;
@@ -86,6 +87,7 @@ static MLKSymbol *_LOOP;
   THROW = [cl intern:@"THROW"];
   LAMBDA = [cl intern:@"LAMBDA"];
   LET = [cl intern:@"LET"];
+  _FLET = [sys intern:@"%FLET"];
   _MACROLET = [sys intern:@"%MACROLET"];
   _LOOP = [sys intern:@"%LOOP"];
   APPLY = [cl intern:@"APPLY"];
@@ -512,6 +514,92 @@ static MLKSymbol *_LOOP;
                   return result;
                 }
             }
+          else if (car == _FLET)
+            {
+              id declarations;
+              id clauses;
+              NSMutableArray *new_clauses;
+              id body;
+              NSArray *result;
+              MLKLexicalContext *ctx;
+              MLKLexicalEnvironment *env;
+
+              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]);
+
+              if (!expandOnly)
+                env = AUTORELEASE ([[MLKLexicalEnvironment alloc]
+                                     initWithParent:lexenv
+                                     variables:nil
+                                     functions:nil]);
+
+              clauses = [[program cdr] car];
+              new_clauses = [NSMutableArray array];
+              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:expandOnly]
+                                      objectAtIndex:0]);
+
+                  [ctx addFunction:name];
+
+                  if (!expandOnly)
+                    [env addFunction:value forSymbol:name];
+                  else
+                    [new_clauses addObject:[MLKCons cons:name with:[value cdr]]];
+
+                  clauses = [clauses cdr];
+                }
+
+              result = [self eval:[MLKCons cons:PROGN with:body]
+                             inLexicalContext:ctx
+                             withEnvironment:env
+                             expandOnly:expandOnly];
+
+              if (expandOnly)
+                {
+                  RETURN_VALUE ([MLKCons
+                                  cons:_FLET
+                                  with:[MLKCons
+                                         cons:[MLKCons listWithArray:new_clauses]
+                                         with:[MLKCons
+                                                cons:[MLKCons cons:DECLARE
+                                                              with:declarations]
+                                                with:[[result objectAtIndex:0] cdr]]]]);
+                }
+              else
+                {
+                  return result;
+                }
+            }
           else if (car == LET)
             {
               id declarations;
-- 
cgit v1.2.3