diff options
Diffstat (limited to 'src/boot/translator.boot')
| -rw-r--r-- | src/boot/translator.boot | 95 |
1 files changed, 0 insertions, 95 deletions
diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 66cf4b56..feb87971 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -352,101 +352,6 @@ shoeConsoleTrees s == shoeAddComment l== strconc('"; ", first l) -++ True if objects of type native type `t' are sensible to GC. -needsStableReference? t == - %hasFeature KEYWORD::GCL => false -- - %hasFeature KEYWORD::SBCL or %hasFeature KEYWORD::CLISP - or %hasFeature KEYWORD::ECL => t = "pointer" or t = "buffer" - true -- don't know; conservatively answer `yes'. - - -++ coerce argument `a' to native type `t', in preparation for -++ a call to a native functions. -coerceToNativeType(a,t) == - %hasFeature KEYWORD::GCL => a - %hasFeature KEYWORD::SBCL => - t = "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a] - t = "string" => a -- 'string's are automatically converted. - needsStableReference? t => - fatalError '"don't know how to coerce argument for native type" - a - %hasFeature KEYWORD::CLISP or %hasFeature KEYWORD::ECL => - needsStableReference? t => - fatalError '"don't know how to coerce argument for native type" - a - fatalError '"don't know how to coerce argument for native type" - -++ filter out arguments that need stable references during call -++ to native function, and convert all arguments as necessary. -prepareArgumentsForNativeCall(args,types) == - unstableArgs := [a for a in args for t in types - | needsStableReference? t] - preparedArgs := [coerceToNativeType(a,t) - for a in args for t in types] - [unstableArgs,preparedArgs] - - -++ Generate an import declaration for `op' as equivalent of the -++ foreign signature `sig'. Here, `foreign' operationally means that -++ the entity is from the C language world. -genImportDeclaration(op, sig) == - sig isnt ["Signature", op', m] => coreError '"invalid signature" - m isnt ["Mapping", t, s] => coreError '"invalid function type" - if not null s and SYMBOLP s then s := [s] - - -- we don't deal with non-trivial return values (yet) - needsStableReference? t => - fatalError '"non trivial return type for native function" - - %hasFeature KEYWORD::GCL => - [["DEFENTRY", op, [nativeType x for x in s], - [nativeType t, SYMBOL_-NAME op']]] - - args := [GENSYM() for x in s] - %hasFeature KEYWORD::SBCL => - [unstableArgs,newArgs] := prepareArgumentsForNativeCall(args,s) - null unstableArgs => - [["DEFUN",op,args, - [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"), - [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op', - ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :args]]] - [["DEFUN",op,args, - [bfColonColon("SB-SYS","WITH-PINNED-OBJECTS"),unstableArgs, - [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"), - [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op', - ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :newArgs]]]] - - %hasFeature KEYWORD::CLISP => - -- there is a curious bug in the CLisp's FFI support whereby - -- foreign declarations compiled separately will have the wrong - -- types when used in other modules. We work around that problem - -- by defining forwarding functions to the foreign declarations - -- in the same module the latter are declared. - foreignDecl := - n := INTERN strconc(SYMBOL_-NAME op, '"%clisp-hack") - [bfColonColon("FFI","DEF-CALL-OUT"),n, - [KEYWORD::NAME,SYMBOL_-NAME op'], - [KEYWORD::ARGUMENTS,:[[a, nativeType x] for x in s for a in args]], - [KEYWORD::RETURN_-TYPE, nativeType t], - [KEYWORD::LANGUAGE,KEYWORD::STDC]] - forwardingFun := - ["DEFUN",op,args, - [n,:[coerceToNativeType(a,t) for a in args for x in s]]] - $foreignsDefsForCLisp := [foreignDecl,:$foreignsDefsForCLisp] - [forwardingFun] - - %hasFeature KEYWORD::ECL => - [["DEFUN",op, args, - [bfColonColon("FFI","C-INLINE"),args,[nativeType x for x in s], - nativeType t, "strconc"/callTemplate(op',#args), - KEYWORD::ONE_-LINER, true]]] where - callTemplate(op,n) == - [SYMBOL_-NAME op,'"(",:[:sharpArg i for i in 0..(n-1)],'")"] - sharpArg i == - i = 0 => ['"#0"] - ['",",'"#", STRINGIMAGE i] - fatalError '"import declaration not implemented for this Lisp" - shoeOutParse stream == $inputStream := stream $stack := [] |