From d41a82c4e21ba8e65432a1c0364b524e2b1896a1 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 6 Jul 2008 20:07:03 +0200
Subject: Interpreter: Add special operator IN-PACKAGE.

---
 MLKInterpreter.m | 14 ++++++++++++++
 MLKPackage.m     |  1 +
 2 files changed, 15 insertions(+)

diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index 778985f..37d4523 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -42,6 +42,7 @@
 static MLKPackage *cl;
 static MLKPackage *sys;
 static MLKSymbol *IF;
+static MLKSymbol *IN_PACKAGE;
 static MLKSymbol *DECLARE;
 static MLKSymbol *PROGN;
 static MLKSymbol *TAGBODY;
@@ -72,6 +73,7 @@ static MLKSymbol *_LAMBDA;
   sys = [MLKPackage findPackage:@"TOILET-SYSTEM"];
 
   IF = [cl intern:@"IF"];
+  IN_PACKAGE = [cl intern:@"IN-PACKAGE"];
   DECLARE = [cl intern:@"DECLARE"];
   PROGN = [cl intern:@"PROGN"];
   TAGBODY = [cl intern:@"TAGBODY"];
@@ -208,6 +210,18 @@ static MLKSymbol *_LAMBDA;
                              inLexicalContext:context
                              withEnvironment:lexenv];                
             }
+          else if (car == IN_PACKAGE)
+            {
+              id cadr = [[program cdr] car];
+              id package = [MLKPackage findPackage:stringify(cadr)];
+
+              [[MLKDynamicContext currentContext]
+                setValue:package
+                forSymbol:[[MLKPackage findPackage:@"COMMON-LISP"]
+                            intern:@"*PACKAGE*"]];
+
+              return [NSArray arrayWithObject:nullify(package)];
+            }
           else if (car == _LAMBDA)
             {
               // A bare-bones LAMBDA without a real lambda list.  What
diff --git a/MLKPackage.m b/MLKPackage.m
index fb5ab20..568dfd3 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -63,6 +63,7 @@ static NSMutableDictionary *packages = nil;
   [cl export:nil];
   [cl export:[cl intern:@"T"]];
   [cl export:[cl intern:@"IF"]];
+  [cl export:[cl intern:@"IN-PACKAGE"]];
   [cl export:[cl intern:@"LET"]];
   [cl export:[cl intern:@"LAMBDA"]];
   [cl export:[cl intern:@"FUNCALL"]];
-- 
cgit v1.2.3