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.

---
 MLKRoot.m | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)

(limited to 'MLKRoot.m')

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