diff options
| -rw-r--r-- | GNUmakefile | 24 | ||||
| -rw-r--r-- | MLKForeignProcedure.h | 47 | ||||
| -rw-r--r-- | MLKForeignProcedure.m | 117 | ||||
| -rw-r--r-- | MLKInterpreter.m | 35 |
4 files changed, 212 insertions, 11 deletions
diff --git a/GNUmakefile b/GNUmakefile index be541ef..7cc4350 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -29,6 +29,7 @@ ifeq ($(DEBUG),YES) ADDITIONAL_OBJCFLAGS += -ggdb3 endif +# I know, I know. I'm emulating ‘configure’ here. *shrug* Whatever. HAVE_FFI_H := $(shell echo '\#include <ffi.h>' | $(CC) $(ADDITIONAL_OBJCFLAGS) -c -o /dev/null -x c - 2>/dev/null && echo YES) ifeq ($(HAVE_FFI_H),YES) @@ -48,20 +49,21 @@ ToiletKit_OBJC_FILES = functions.m globals.m MLKBackquoteReader.m \ MLKCompiledProcedure.m MLKCons.m MLKDoubleFloat.m \ MLKDispatchingMacroCharacterReader.m \ MLKDynamicContext.m MLKEnvironment.m MLKFloat.m \ - MLKInteger.m MLKInterpretedClosure.m \ - MLKInterpreter.m MLKLexicalContext.m \ - MLKLexicalEnvironment.m MLKLispValue.m \ - MLKNumber.m MLKPackage.m MLKParenReader.m \ - MLKQuoteReader.m MLKRatio.m MLKReader.m \ - MLKReadtable.m MLKReaderError.m MLKRoot.m \ - MLKSemicolonReader.m MLKSharpsignColonReader.m \ - MLKSingleFloat.m MLKStream.m \ - MLKStringInputStream.m MLKStringOutputStream.m \ - MLKStringReader.m MLKSymbol.m MLKThrowException.m \ + MLKForeignProcedure.m MLKInteger.m \ + MLKInterpretedClosure.m MLKInterpreter.m \ + MLKLexicalContext.m MLKLexicalEnvironment.m \ + MLKLispValue.m MLKNumber.m MLKPackage.m \ + MLKParenReader.m MLKQuoteReader.m MLKRatio.m \ + MLKReader.m MLKReadtable.m MLKReaderError.m \ + MLKRoot.m MLKSemicolonReader.m \ + MLKSharpsignColonReader.m MLKSingleFloat.m \ + MLKStream.m MLKStringInputStream.m \ + MLKStringOutputStream.m MLKStringReader.m \ + MLKSymbol.m MLKThrowException.m \ MLKValuesFunction.m NSObject-MLKPrinting.m \ NSString-MLKPrinting.m ToiletKit_OBJCFLAGS = -Wall -ToiletKit_LDFLAGS = -lgmp -lffi +ToiletKit_LDFLAGS = -lgmp -lffi -ldl #LIBRARIES_DEPEND_UPON #TOOL_NAME = etoilet diff --git a/MLKForeignProcedure.h b/MLKForeignProcedure.h new file mode 100644 index 0000000..d424de4 --- /dev/null +++ b/MLKForeignProcedure.h @@ -0,0 +1,47 @@ +/* -*- 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 <http://www.gnu.org/licenses/>. + */ + +#import "MLKFuncallable.h" +#import "MLKLispValue.h" +#import "MLKLexicalContext.h" +#import "MLKLexicalEnvironment.h" + +#import <Foundation/NSArray.h> +#import <Foundation/NSString.h> + +#import "functions.h" + + +@interface MLKForeignProcedure : MLKLispValue <MLKFuncallable> +{ + void *_code; + MLKForeignType *_argumentTypes; + MLKForeignType _returnType; +} + +-(id) initWithCode:(void *)code + argumentTypes:(NSArray *)argTypes + returnType:(id)returnType; + +-(NSArray *) applyToArray:(NSArray *)arguments; + +-(NSString *) description; +-(NSString *) descriptionForLisp; + +-(void) dealloc; +@end diff --git a/MLKForeignProcedure.m b/MLKForeignProcedure.m new file mode 100644 index 0000000..fa889cb --- /dev/null +++ b/MLKForeignProcedure.m @@ -0,0 +1,117 @@ +/* -*- 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 <http://www.gnu.org/licenses/>. + */ + +#import "MLKForeignProcedure.h" +#import "globals.h" +#import "util.h" + +#import <Foundation/NSArray.h> +#import <Foundation/NSEnumerator.h> + +#ifdef HAVE_FFI_H +#include <ffi.h> +#elif HAVE_FFI_FFI_H +#include <ffi/ffi.h> +#endif + +#include <stdlib.h> + + +@implementation MLKForeignProcedure +-(id) initWithCode:(void *)code + argumentTypes:(NSArray *)argTypes + returnType:(id)returnType +{ + int i; + NSEnumerator *e; + id el; + + self = [super init]; + + _code = code; + _returnType = MLKForeignTypeWithTypeDesignator (returnType); + + _argumentTypes = malloc (sizeof (MLKForeignType) * [argTypes count]); + + e = [argTypes objectEnumerator]; + i = 0; + while ((el = [e nextObject])) + { + _argumentTypes[i++] = MLKForeignTypeWithTypeDesignator (denullify (el)); + } + + return self; +} + +-(NSArray *) applyToArray:(NSArray *)arguments +{ + int argc = [arguments count]; + ffi_cif cif; + ffi_type *arg_types[argc]; + ffi_type *return_type; + ffi_status status; + void *argv[argc]; + id return_value; + int i; + + for (i = 0; i < argc; i++) + { + arg_types[i] = + MLKFFITypeWithForeignType (_argumentTypes[i]); + argv[i] = alloca (arg_types[i]->size); + MLKSetForeignValueWithLispValue (argv[i], + [arguments objectAtIndex:i], + _argumentTypes[i]); + } + + return_type = MLKFFITypeWithForeignType (_returnType); + + status = ffi_prep_cif (&cif, FFI_DEFAULT_ABI, argc, return_type, arg_types); + if (status != FFI_OK) + { + [NSException raise:@"MLKInvalidFFITypeException" + format:@"FFI type is invalid (this is probably a bug)."]; + } + + ffi_call (&cif, FFI_FN (_code), &return_value, (void**)argv); + + // FIXME + if (return_type == &ffi_type_void) + return [NSArray array]; + else + return [NSArray arrayWithObject:nullify (MLKLispValueWithForeignValue (&return_value, _returnType))]; +} + +-(NSString *) description +{ + return MLKPrintToString(self); +} + +-(NSString *) descriptionForLisp +{ + return [NSString stringWithFormat:@"<Compiled procedure @%p>", self]; +} + +-(void) dealloc +{ + // FIXME: Can we really just use free() here? + free (_code); + free (_argumentTypes); + [super dealloc]; +} +@end diff --git a/MLKInterpreter.m b/MLKInterpreter.m index fcc0e84..64e23de 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -16,10 +16,15 @@ * along with this program. If not, see <http://www.gnu.org/licenses/>. */ +#define _XOPEN_SOURCE 600 +#define _GNU_SOURCE // for RTLD_DEFAULT +#define _ISOC99_SOURCE + #import "MLKInterpretedClosure.h" #import "MLKCons.h" #import "MLKDynamicContext.h" #import "MLKEnvironment.h" +#import "MLKForeignProcedure.h" #import "MLKFuncallable.h" #import "MLKInterpreter.h" #import "MLKLexicalContext.h" @@ -37,6 +42,12 @@ #import <Foundation/NSNull.h> #import <Foundation/NSString.h> +#ifndef _WIN32 +#include <dlfcn.h> +#else +#include <windows.h> +#endif + #include <stdio.h> @@ -72,6 +83,7 @@ static MLKSymbol *PROGV; static MLKSymbol *UNWIND_PROTECT; static MLKSymbol *VALUES; static MLKSymbol *_DEFMACRO; +static MLKSymbol *_FOREIGN_LAMBDA; static MLKSymbol *_LAMBDA; static MLKSymbol *_LOOP; static MLKSymbol *V_INITP; @@ -120,6 +132,7 @@ static MLKSymbol *MULTIPLE_VALUE_CALL; VALUES = [cl intern:@"VALUES"]; UNWIND_PROTECT = [cl intern:@"UNWIND-PROTECT"]; _DEFMACRO = [sys intern:@"%DEFMACRO"]; + _FOREIGN_LAMBDA = [sys intern:@"%FOREIGN-LAMBDA"]; _LAMBDA = [sys intern:@"%LAMBDA"]; V_INITP = [sys intern:@"*SYSTEM-INITIALISED-P*"]; MULTIPLE_VALUE_CALL = [cl intern:@"MULTIPLE-VALUE-CALL"]; @@ -473,6 +486,28 @@ static MLKSymbol *MULTIPLE_VALUE_CALL; } } } + else if (car == _FOREIGN_LAMBDA) + { + int (*function)(); + NSString *name = [[program cdr] car]; + id libraryDesignator = [[[program cdr] cdr] car]; + id argtypes = [[[[program cdr] cdr] cdr] car]; + id returnType = [[[[[program cdr] cdr] cdr] cdr] car]; + + // FIXME: Support library designators. + +#ifdef _WIN32 + EnumProcessModules (...); + GetProcAddress (..., [name UTF8String]); +#else + function = dlsym (RTLD_DEFAULT, [name UTF8String]); +#endif + + return LAUTORELEASE ([[MLKForeignProcedure alloc] + initWithCode:function + argumentTypes:[argtypes array] + returnType:returnType]); + } else if (car == FUNCTION) { id functionName = [[program cdr] car]; |