diff options
| -rw-r--r-- | MLKPackage.m | 6 | ||||
| -rw-r--r-- | MLKRoot.m | 78 |
2 files changed, 83 insertions, 1 deletions
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*"]]; @@ -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 |