/* -*- mode: objc; coding: utf-8 -*- */ /* Toilet Lisp, a Common Lisp subset for the Étoilé runtime. * Copyright (C) 2008 Matthias Andreas Benkard. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or (at * your option) any later version. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #import "MLKBinding.h" #import "MLKCharacter.h" #import "MLKCons.h" #import "MLKDynamicContext.h" #import "MLKInterpretedClosure.h" #import "MLKInterpreter.h" #import "MLKNumber.h" #import "MLKPackage.h" #import "MLKRoot.h" #import "MLKStream.h" #import "MLKSymbol.h" #import "MLKInteger.h" #import "MLKSingleFloat.h" #import "MLKDoubleFloat.h" #import "NSObject-MLKPrinting.h" #import "runtime-compatibility.h" #import "util.h" #import #import #import #import #import #import #import #include static NSMethodSignature *signature; static MLKPackage *sys; static MLKPackage *cl; static id truify (BOOL value) { return (value ? (id) [cl intern:@"T"] : nil); } #define RETURN_VALUE(thing) \ { return [NSArray arrayWithObject:nullify(thing)]; } @implementation MLKRoot +(void) initialize { signature = LRETAIN ([self methodSignatureForSelector:@selector(car:)]); sys = [MLKPackage findPackage:@"TOILET-SYSTEM"]; cl = [MLKPackage findPackage:@"COMMON-LISP"]; } +(NSArray *) dispatch:(MLKSymbol *)name withArguments:(NSArray *)args { NSInvocation *invocation; NSMutableString *methodName; NSArray *result; SEL selector; BOOL nothing_found; nothing_found = NO; NS_DURING { if ([sys findSymbol:[name name]] != name) NS_VALUERETURN (nil, NSArray *); } NS_HANDLER { nothing_found = YES; } NS_ENDHANDLER; if (nothing_found) return nil; invocation = [NSInvocation invocationWithMethodSignature:signature]; methodName = [NSMutableString stringWithString:[[name name] lowercaseString]]; [methodName replaceOccurrencesOfString:@"-" withString:@"_" options:NSLiteralSearch range:NSMakeRange(0, [methodName length])]; [methodName appendString:@":"]; selector = NSSelectorFromString (methodName); if (!selector || ![self respondsToSelector:selector]) return nil; [invocation setSelector:selector]; [invocation setTarget:self]; [invocation setArgument:&args atIndex:2]; [invocation invoke]; [invocation getReturnValue:&result]; return result; } +(NSArray *) car:(NSArray *)args { return [NSArray arrayWithObject:nullify([denullify([args objectAtIndex:0]) car])]; } +(NSArray *) cdr:(NSArray *)args { return [NSArray arrayWithObject:nullify([denullify([args objectAtIndex:0]) cdr])]; } +(NSArray *) rplaca:(NSArray *)args { MLKCons *cons = [args objectAtIndex:0]; [cons setCar:denullify([args objectAtIndex:1])]; RETURN_VALUE (cons); } +(NSArray *) rplacd:(NSArray *)args { MLKCons *cons = [args objectAtIndex:0]; [cons setCdr:denullify([args objectAtIndex:1])]; RETURN_VALUE (cons); } +(NSArray *) cons:(NSArray *)args { return [NSArray arrayWithObject: [MLKCons cons:denullify([args objectAtIndex:0]) with:denullify([args objectAtIndex:1])]]; } +(NSArray *) load:(NSArray *)args { // FIXME BOOL success; int l, i; NSString *fileName = denullify ([args objectAtIndex:0]); NSInputStream *input = [NSInputStream inputStreamWithFileAtPath:fileName]; MLKStream *stream = LAUTORELEASE ([[MLKStream alloc] initWithInputStream:input]); MLKDynamicContext *oldContext = [MLKDynamicContext currentContext]; int level = MLKIntWithInteger ([oldContext valueForSymbol:[sys intern:@"*LOAD-LEVEL*"]]); MLKDynamicContext *ctx; l = [fileName length]; fprintf (stderr, ";\n; "); for (i = 0; i < 68 - 2*level; i++) fprintf (stderr, "_"); fprintf (stderr, "\n; /"); for (i = 0; i < 30 - l/2 - level; i++) fprintf (stderr, "-"); fprintf (stderr, " LOAD: %s ", [fileName UTF8String]); for (i = 0; i < 30 - (l+1)/2 - level; i++) fprintf (stderr, "-"); fprintf (stderr, "\n; |\n"); //NSLog (@"%d", [input hasBytesAvailable]); [input open]; //NSLog (@"%d", [input hasBytesAvailable]); ctx = [[MLKDynamicContext alloc] initWithParent:oldContext variables:nil handlers:nil restarts:nil catchTags:nil activeHandlerEnvironment:nil]; [ctx addValue:MLKIntegerWithInt(level + 1) forSymbol:[sys intern:@"*LOAD-LEVEL*"]]; [ctx pushContext]; NS_DURING { success = [MLKInterpreter load:stream verbose:YES print:YES]; } NS_HANDLER { [MLKDynamicContext popContext]; LRELEASE (ctx); [input close]; } NS_ENDHANDLER; [MLKDynamicContext popContext]; LRELEASE (ctx); [input close]; fprintf (stderr, "; \\"); for (i = 0; i < 68 - 2*level; i++) fprintf (stderr, "_"); fprintf (stderr, "\n; \n"); RETURN_VALUE (truify (success)); } +(NSArray *) eq:(NSArray *)args { RETURN_VALUE (truify ([args objectAtIndex:0] == [args objectAtIndex:1])); } +(NSArray *) fixnum_eq:(NSArray *)args { #ifdef NO_FIXNUMS RETURN_VALUE (truify ([[args objectAtIndex:0] isEqual:[args objectAtIndex:1]])); #else RETURN_VALUE (truify (denullify([args objectAtIndex:0]) == denullify([args objectAtIndex:1]))); #endif } +(NSArray *) symbolp:(NSArray *)args { id arg0 = [args objectAtIndex:0]; RETURN_VALUE (truify (arg0 == [NSNull null] || [arg0 isKindOfClass:[MLKSymbol class]])); } +(NSArray *) listp:(NSArray *)args { id arg0 = [args objectAtIndex:0]; RETURN_VALUE (truify (arg0 == [NSNull null] || [arg0 isKindOfClass:[MLKCons class]])); } +(NSArray *) consp:(NSArray *)args { id arg0 = [args objectAtIndex:0]; RETURN_VALUE (truify ([arg0 isKindOfClass:[MLKCons class]])); } +(NSArray *) atom:(NSArray *)args { id arg0 = [args objectAtIndex:0]; RETURN_VALUE (truify (![arg0 isKindOfClass:[MLKCons class]])); } +(NSArray *) null:(NSArray *)args { RETURN_VALUE (truify ([args objectAtIndex:0] == [NSNull null])); } +(NSArray *) fixnump:(NSArray *)args { id arg0 = denullify ([args objectAtIndex:0]); RETURN_VALUE (truify (MLKFixnumP (arg0))); } +(NSArray *) add:(NSArray *)args { RETURN_VALUE ([((MLKNumber*)[args objectAtIndex:0]) add:[args objectAtIndex:1]]); } +(NSArray *) subtract:(NSArray *)args { RETURN_VALUE ([((MLKNumber*)[args objectAtIndex:0]) subtract:[args objectAtIndex:1]]); } +(NSArray *) multiply:(NSArray *)args { RETURN_VALUE ([((MLKNumber*)[args objectAtIndex:0]) multiplyWith:[args objectAtIndex:1]]); } +(NSArray *) divide:(NSArray *)args { RETURN_VALUE ([((MLKNumber*)[args objectAtIndex:0]) divideBy:[args objectAtIndex:1]]); } +(NSArray *) add_fixnums:(NSArray *)args { RETURN_VALUE (MLKAddFixnums (denullify([args objectAtIndex:0]), denullify([args objectAtIndex:1]))); } +(NSArray *) subtract_fixnums:(NSArray *)args { RETURN_VALUE (MLKSubtractFixnums (denullify([args objectAtIndex:0]), denullify([args objectAtIndex:1]))); } +(NSArray *) multiply_fixnums:(NSArray *)args { RETURN_VALUE (MLKMultiplyFixnums (denullify([args objectAtIndex:0]), denullify([args objectAtIndex:1]))); } +(NSArray *) idivide_fixnums:(NSArray *)args { RETURN_VALUE (MLKIDivideFixnums (denullify([args objectAtIndex:0]), denullify([args objectAtIndex:1]))); } +(NSArray *) list:(NSArray *)args { RETURN_VALUE ([MLKCons listWithArray:args]); } +(NSArray *) macroexpand_1:(NSArray *)args { id form = [args objectAtIndex:0]; id env = [args count] > 1 ? denullify([args objectAtIndex:1]) : nil; MLKLexicalContext *context = env ? (id)env : (id)[MLKLexicalContext globalContext]; id macrofun = nil; if ([form isKindOfClass:[MLKCons class]] && (![form car] || [[form car] isKindOfClass:[MLKSymbol class]]) && [context symbolNamesMacro:[form car]]) { macrofun = [context macroForSymbol:[form car]]; } else if ([form isKindOfClass:[MLKSymbol class]] && [context symbolNamesSymbolMacro:form]) { macrofun = [context symbolMacroForSymbol:[form car]]; } if (macrofun) { form = denullify ([[macrofun applyToArray: [NSArray arrayWithObjects: form, context, nil]] objectAtIndex:0]); } RETURN_VALUE (form); } +(NSArray *) macroexpand_all:(NSArray *)args { id form = [args objectAtIndex:0]; id env = [args count] > 1 ? denullify([args objectAtIndex:1]) : nil; MLKLexicalContext *context = env ? (id)env : (id)[MLKLexicalContext globalContext]; return [MLKInterpreter eval:form inLexicalContext:context withEnvironment:nil expandOnly:YES]; } +(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"]); } +(NSArray *) find_package:(NSArray *)args { NSString *name = stringify (denullify ([args objectAtIndex:0])); MLKPackage *package = [MLKPackage findPackage:name]; if (package) { RETURN_VALUE (package); } else { [NSException raise:@"MLKNoSuchPackageError" format:@"The package %@ does not exist", MLKPrintToString(name)]; return nil; } } +(NSArray *) string:(NSArray *)args { RETURN_VALUE (stringify (denullify ([args objectAtIndex:0]))); } +(NSArray *) gensym:(NSArray *)args { NSString *prefix; NSString *suffix; MLKBinding *gensymCounter = [[MLKDynamicContext currentContext] bindingForSymbol: [[MLKPackage findPackage:@"COMMON-LISP"] intern:@"*GENSYM-COUNTER*"]]; if ([args count] > 0) { id x = [args objectAtIndex:0]; if ([x isKindOfClass:[NSString class]]) { prefix = x; suffix = MLKPrintToString([gensymCounter value]); [gensymCounter setValue:[(MLKInteger*)[gensymCounter value] add:[MLKInteger integerWithInt:1]]]; } else if ([x isKindOfClass:[MLKInteger class]]) { // x must be an integer. prefix = @"G"; suffix = MLKPrintToString(x); } else { [NSException raise:@"MLKTypeError" format:@"%@ is not of type (OR INTEGER STRING).", x]; return nil; } } else { prefix = @"G"; suffix = MLKPrintToString([gensymCounter value]); [gensymCounter setValue:[(MLKInteger*)[gensymCounter value] add:[MLKInteger integerWithInt:1]]]; } RETURN_VALUE (([MLKSymbol symbolWithName:[NSString stringWithFormat:@"%@%@", prefix, suffix] package:nil])); } +(NSArray *) make_symbol:(NSArray *)args { NSString *name = [args objectAtIndex:0]; RETURN_VALUE ([MLKSymbol symbolWithName:name package:nil]); } +(NSArray *) intern:(NSArray *)args { NSString *name = [args objectAtIndex:0]; id package = denullify (([args count] > 1 ? [args objectAtIndex:1] : [[MLKDynamicContext currentContext] valueForSymbol: [[MLKPackage findPackage:@"COMMON-LISP"] intern:@"*PACKAGE*"]])); MLKSymbol *symbol = [package intern:name]; RETURN_VALUE (symbol); } +(NSArray *) import:(NSArray *)args { MLKSymbol *symbol = [args objectAtIndex:0]; id package = denullify (([args count] > 1 ? [args objectAtIndex:1] : [[MLKDynamicContext currentContext] valueForSymbol: [[MLKPackage findPackage:@"COMMON-LISP"] intern:@"*PACKAGE*"]])); [package import:symbol]; RETURN_VALUE ([cl intern:@"T"]); } +(NSArray *) objc_class_of:(NSArray *)args { RETURN_VALUE ([[args objectAtIndex:0] class]); } +(NSArray *) objc_subclassp:(NSArray *)args { RETURN_VALUE (truify ([[args objectAtIndex:0] isSubclassOfClass: [args objectAtIndex:1]])); } +(NSArray *) find_objc_class:(NSArray *)args { RETURN_VALUE (NSClassFromString ([args objectAtIndex:0])); } +(NSArray *) ns_log:(NSArray *)args { NSString *description = MLKPrintToString([args objectAtIndex:0]); NSLog (@"%@", description); RETURN_VALUE ([args objectAtIndex:0]); } +(NSArray *) symbol_name:(NSArray *)args { MLKSymbol *symbol = denullify ([args objectAtIndex:0]); RETURN_VALUE (symbol ? (id)[symbol name] : (id)@"NIL"); } +(NSArray *) primitive_type_of:(NSArray *)args { id object = denullify ([args objectAtIndex:0]); if (!object) { RETURN_VALUE ([cl intern:@"NULL"]); } else if (MLKFixnumP (object)) { RETURN_VALUE ([cl intern:@"FIXNUM"]); } else if ([object isKindOfClass:[MLKSymbol class]]) { RETURN_VALUE ([cl intern:@"SYMBOL"]); } else if ([object isKindOfClass:[MLKCons class]]) { RETURN_VALUE ([cl intern:@"CONS"]); } else if ([object isKindOfClass:[MLKDoubleFloat class]]) { RETURN_VALUE ([cl intern:@"DOUBLE-FLOAT"]); } else if ([object isKindOfClass:[MLKSingleFloat class]]) { RETURN_VALUE ([cl intern:@"SINGLE-FLOAT"]); } else if ([object isKindOfClass:[MLKInteger class]]) { RETURN_VALUE ([cl intern:@"INTEGER"]); } else if ([object isKindOfClass:[MLKCharacter class]]) //FIXME: STANDARD-CHAR { RETURN_VALUE ([cl intern:@"BASE-CHAR"]); } else if ([object isKindOfClass:[MLKInterpretedClosure class]]) { RETURN_VALUE ([cl intern:@"FUNCTION"]); } else if ([object isKindOfClass:[MLKLexicalContext class]]) { RETURN_VALUE ([sys intern:@"LEXICAL-CONTEXT"]); } else if ([object isKindOfClass:[MLKBinding class]]) { RETURN_VALUE ([sys intern:@"BINDING"]); } else if ([object isKindOfClass:[MLKPackage class]]) { RETURN_VALUE ([cl intern:@"PACKAGE"]); } else if ([object isKindOfClass:[MLKStream class]]) { RETURN_VALUE ([cl intern:@"STREAM"]); } else if ([object isKindOfClass:[NSException class]]) { RETURN_VALUE ([sys intern:@"EXCEPTION"]); } else if ([object isKindOfClass:[NSArray class]]) { RETURN_VALUE ([cl intern:@"ARRAY"]); } else { RETURN_VALUE ([cl intern:@"T"]); } } +(NSArray *) send_by_name:(NSArray *)args { NSString *methodName = denullify ([args objectAtIndex:1]); id object = denullify ([args objectAtIndex:0]); NSInvocation *invocation; SEL selector; NSMethodSignature *signature; int i; MLKForeignType returnType; if (MLKFixnumP (object)) object = [MLKInteger integerWithFixnum:object]; selector = NSSelectorFromString (methodName); if (!selector) { [NSException raise:@"MLKNoSuchSelectorError" format:@"Could not find a selector named %@", methodName]; } signature = [object methodSignatureForSelector:selector]; if (!signature) { [NSException raise:@"MLKDoesNotUnderstandError" format:@"%@ does not respond to selector %@", object, methodName]; } invocation = [NSInvocation invocationWithMethodSignature:signature]; [invocation setSelector:selector]; [invocation setTarget:object]; for (i = 2; i < [args count]; i++) { id argument = denullify ([args objectAtIndex:i]); const char *objctype = [signature getArgumentTypeAtIndex:i]; MLKForeignType type = MLKForeignTypeWithObjectiveCType (objctype); ffi_type *ffi_argtype = MLKFFITypeWithForeignType (type); void *argbuf = alloca (ffi_argtype->size); if (type == MLKT_INVALID) [NSException raise:@"MLKInvalidArgumentError" format:@"Don't know how to coerce %@ into type \"%s\".", argument, objctype]; MLKSetForeignValueWithLispValue (argbuf, argument, type); [invocation setArgument:argbuf atIndex:i]; } [invocation invoke]; returnType = MLKForeignTypeWithObjectiveCType ([signature methodReturnType]); if (returnType == MLKT_INVALID) { [NSException raise:@"MLKInvalidReturnTypeError" format:@"Cannot handle an Objective-C return type of \"%s\" \ as provided by method %@ of object %@", methodName, object, [signature methodReturnType]]; return nil; } else if (returnType == MLKT_VOID) { return [NSArray array]; } else { ffi_type *ffi_rettype = MLKFFITypeWithForeignType (returnType); void *returnValue = alloca (ffi_rettype->size); [invocation getReturnValue:returnValue]; RETURN_VALUE (MLKLispValueWithForeignValue (returnValue, returnType)); } } +(NSArray *) declarations_and_doc_and_forms:(NSArray *)args { id decls, doc, forms; id bodyAndDecls = denullify ([args objectAtIndex:0]); MLKSplitDeclarationsDocAndForms (&decls, &doc, &forms, bodyAndDecls, YES); RETURN_VALUE ([MLKCons cons:decls with:[MLKCons cons:doc with:[MLKCons cons:forms with:nil]]]); } +(NSArray *) declarations_and_forms:(NSArray *)args { id decls, doc, forms; id bodyAndDecls = denullify ([args objectAtIndex:0]); MLKSplitDeclarationsDocAndForms (&decls, &doc, &forms, bodyAndDecls, NO); RETURN_VALUE ([MLKCons cons:decls with:[MLKCons cons:forms with:nil]]); } @end