From 2dbc9e8eb087972b8b18a186a20a28bc0cfc8a9b Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 6 Jul 2008 16:06:38 +0200
Subject: Implement EXPORT, SHADOW, and UNEXPORT.

---
 MLKPackage.m |  6 ++++-
 MLKRoot.m    | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 83 insertions(+), 1 deletion(-)

diff --git a/MLKPackage.m b/MLKPackage.m
index 1e445b3..eace2a7 100644
--- a/MLKPackage.m
+++ b/MLKPackage.m
@@ -39,7 +39,8 @@ static NSMutableDictionary *packages = nil;
                                    nicknames:[NSSet setWithObject:@"CL-USER"]];;
   MLKPackage *sys = [MLKPackage packageWithName:@"TOILET-SYSTEM"
                                 nicknames:[NSSet setWithObjects:
-                                                   @"TL-SYS", nil]];
+                                                   @"TL-SYS", @"SYSTEM",
+                                                   @"SYS", nil]];
   MLKPackage *toilet = [MLKPackage packageWithName:@"TOILET-LISP"
                                    nicknames:[NSSet setWithObjects:
                                                       @"TL", @"TOILET", nil]];
@@ -100,6 +101,9 @@ static NSMutableDictionary *packages = nil;
   [sys export:[sys intern:@"DIVIDE"]];
   [sys export:[sys intern:@"LIST"]];
   [sys export:[sys intern:@"MACROEXPAND-1"]];
+  [sys export:[sys intern:@"EXPORT"]];
+  [sys export:[sys intern:@"SHADOW"]];
+  [sys export:[sys intern:@"UNEXPORT"]];
 
   [cl export:[cl intern:@"*BREAK-ON-SIGNALS*"]];
   [cl export:[cl intern:@"*COMPILE-FILE-PATHNAME*"]];
diff --git a/MLKRoot.m b/MLKRoot.m
index a9e15d3..7ef7339 100644
--- a/MLKRoot.m
+++ b/MLKRoot.m
@@ -17,6 +17,7 @@
  */
 
 #import "MLKCons.h"
+#import "MLKDynamicContext.h"
 #import "MLKInterpreter.h"
 #import "MLKPackage.h"
 #import "MLKRoot.h"
@@ -47,6 +48,17 @@ static id truify (BOOL value)
   return (value ? (id) [cl intern:@"T"] : nil);
 }
 
+static id stringify (id thing)
+{
+  // FIXME.
+  if (!thing)
+    return @"NIL";
+  if ([thing isKindOfClass:[NSString class]])
+    return thing;
+  else if ([thing isKindOfClass:[MLKSymbol class]])
+    return [thing name];
+}
+
 #define RETURN_VALUE(thing)                     \
   return [NSArray arrayWithObject:nullify(thing)];
 
@@ -227,4 +239,70 @@ static id truify (BOOL value)
 
   RETURN_VALUE (form);
 }
+
++(NSArray *) shadow:(NSArray *)args
+{
+  id symbols = denullify ([args objectAtIndex:0]);
+  id package = denullify (([args count] > 1
+                           ? [args objectAtIndex:1]
+                           : [[MLKDynamicContext currentContext]
+                               valueForSymbol:
+                                 [[MLKPackage findPackage:@"COMMON-LISP"]
+                                   intern:@"*PACKAGE*"]]));
+
+  if (![symbols isKindOfClass:[MLKCons class]])
+    symbols = [MLKCons cons:symbols with:nil];
+
+  do
+    {
+      [package shadow:stringify([symbols car])];
+    }
+  while ((symbols = [symbols cdr]));
+
+  RETURN_VALUE ([cl intern:@"T"]);
+}
+
++(NSArray *) export:(NSArray *)args
+{
+  id symbols = denullify ([args objectAtIndex:0]);
+  id package = denullify (([args count] > 1
+                           ? [args objectAtIndex:1]
+                           : [[MLKDynamicContext currentContext]
+                               valueForSymbol:
+                                 [[MLKPackage findPackage:@"COMMON-LISP"]
+                                   intern:@"*PACKAGE*"]]));
+
+  if (![symbols isKindOfClass:[MLKCons class]])
+    symbols = [MLKCons cons:symbols with:nil];
+
+  do
+    {
+      [package export:[symbols car]];
+    }
+  while ((symbols = [symbols cdr]));
+
+  RETURN_VALUE ([cl intern:@"T"]);
+}
+
++(NSArray *) unexport:(NSArray *)args
+{
+  id symbols = denullify ([args objectAtIndex:0]);
+  id package = denullify (([args count] > 1
+                           ? [args objectAtIndex:1]
+                           : [[MLKDynamicContext currentContext]
+                               valueForSymbol:
+                                 [[MLKPackage findPackage:@"COMMON-LISP"]
+                                   intern:@"*PACKAGE*"]]));
+
+  if (![symbols isKindOfClass:[MLKCons class]])
+    symbols = [MLKCons cons:symbols with:nil];
+
+  do
+    {
+      [package unexport:[symbols car]];
+    }
+  while ((symbols = [symbols cdr]));
+
+  RETURN_VALUE ([cl intern:@"T"]);
+}
 @end
-- 
cgit v1.2.3