diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/boot-pkg.lisp | 5 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 132 | ||||
| -rw-r--r-- | src/interp/define.boot | 5 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 28 | ||||
| -rw-r--r-- | src/interp/functor.boot | 10 | ||||
| -rw-r--r-- | src/interp/sys-constants.boot | 5 | ||||
| -rw-r--r-- | src/interp/vmlisp.lisp | 6 |
7 files changed, 165 insertions, 26 deletions
diff --git a/src/interp/boot-pkg.lisp b/src/interp/boot-pkg.lisp index da92dd24..a0dbf0fb 100644 --- a/src/interp/boot-pkg.lisp +++ b/src/interp/boot-pkg.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007-2008, Gabriel Dos Reis. +;; Copyright (C) 2007-2009, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -44,7 +44,8 @@ "loadSystemRuntimeCore" "loadFileIfPresent" "$InteractiveMode" - "string2BootTree")) + "string2BootTree" + "genImportDeclaration")) (in-package "BOOT") diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index b2906c81..399e6a5e 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -202,6 +202,17 @@ compTypeOf(x:=[op,:argl],m,e) == e:= put(op,'modemap,newModemap,e) comp3(x,m,e) +++ We just determined that `op' is called with argument list `args', where +++ `op' is either a local capsule function, or an external function +++ with a local signature-import declaration. Emit insn for the call. +emitLocalCallInsn: (%Symbol,%List,%Env) -> %Code +emitLocalCallInsn(op,args,e) == + op' := -- Find out the linkage name for `op'. + linkName := get(op,"%Link",e) => linkName + encodeLocalFunctionName op + get(op,"%Lang",e) => [op',:args] -- non-Spad calling convention + [op',:args,"$"] + applyMapping([op,:argl],m,e,ml) == #argl^=#ml-1 => nil isCategoryForm(first ml,e) => @@ -220,11 +231,7 @@ applyMapping([op,:argl],m,e,ml) == if argl'="failed" then return nil form:= atom op and not(op in $formalArgList) and null (u := get(op,"value",e)) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:argl',"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + emitLocalCallInsn(op,argl',e) -- Compiler synthetized operators are inline. u ^= nil and u.expr is ["XLAM",:.] => ["call",u.expr,:argl'] ['call,['applyFun,op],:argl'] @@ -694,11 +701,7 @@ compApplication(op,argl,m,T) == argTl = "failed" => nil form:= atom T.expr and not (MEMQ(op,$formalArgList) or MEMQ(T.expr,$formalArgList)) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:[a.expr for a in argTl],"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr) + emitLocalCallInsn(T.expr,[a.expr for a in argTl],e) ['call, ['applyFun, T.expr], :[a.expr for a in argTl]] coerce([form, retm, e],resolve(retm,m)) op = 'elt => nil @@ -1253,11 +1256,117 @@ compFromIf(a,m,E) == a="%noBranch" => ["%noBranch",m,E] comp(a,m,E) -compImport: (%Form,%Mode,%Env) -> %Maybe %Triple +compImport: (%Form,%Mode,%Env) -> %Triple compImport(["import",:doms],m,e) == for dom in doms repeat e:=addDomain(dom,e) ["/throwAway",$NoValueMode,e] +--% Foreign Function Interface + +bootDenotation: %Symbol -> %Symbol +bootDenotation s == + INTERN(SYMBOL_-NAME s,"BOOTTRAN") + +++ Return the Boot denotation of a basic FFI type. +getBasicFFIType: %Mode -> %Symbol +getBasicFFIType t == + t = $Byte => bootDenotation "byte" + t = $Int32 => bootDenotation "int32" + t = $Int64 => bootDenotation "int64" + t = $SingleInteger => bootDenotation "int" + t = $SingleFloat => bootDenotation "float" + t = $DoubleFloat => bootDenotation "double" + t = $String => bootDenotation "string" + nil + +++ Return the Boot denotation of an FFI datatype. This is either +++ a basic VM type, or a simple array of sized integer or floating +++ point type. +getFFIDatatype: %Mode -> %Form +getFFIDatatype t == + x := getBasicFFIType t => x + t is [m,["PrimitiveArray",t']] and m in '(ReadOnly WriteOnly) and + member(t',[$Byte,$Int32,$Int64,$SingleFloat,$DoubleFloat]) => + m' := + m = "ReadOnly" => bootDenotation "readonly" + bootDenotation "writeonly" + [m',[bootDenotation "buffer",getBasicFFIType t']] + nil + +++ Return the Boot denotation of a type that is valid in a external entity +++ signature. +getBootType: %Mode -> %Form +getBootType t == + x := getFFIDatatype t => x + t is ["Mapping",ret,:args] => + ret' := + ret = $Void => bootDenotation "void" + getBasicFFIType ret or return nil + args' := [getFFIDatatype arg or return "failed" for arg in args] + args' = "failed" => return nil + [bootDenotation "Mapping",ret',args'] + nil + +++ Verify that mode `t' is admissible in an external entity signature +++ specification, and return its Boot denotation. +checkExternalEntityType(t,e) == + atom t => + stackAndThrow('"Type variable not allowed in import of external entity",nil) + t' := getBootType t => t' + stackAndThrow('"Type %1bp is invalid in a foreign signature",[t]) + + +++ An external entity named `id' is being imported under signature +++ `type' from a foreign language `lang'. Check that the import +++ is valid, and if so return the linkage name of the entity. +checkExternalEntity(id,type,lang,e) == + checkVariableName id + -- An external entity name shall be unique in scope. + getmode(id,e) => + stackAndThrow('"%1b is already in scope",[id]) + -- In particular, an external entity name cannot be overloaded + -- with exported operators. + get(id,"modemap",e) => + stackAndThrow('"%1b already names exported operations in scope",[id]) + -- Only functions are accepted at the moment. And all mentioned + -- types must be those that are supported by the FFI. + type' := checkExternalEntityType(type,e) + type' isnt [=bootDenotation "Mapping",:.] => + stackAndThrow('"Signature for external entity must be a Mapping type",nil) + id' := encodeLocalFunctionName id + [def] := genImportDeclaration(id',[bootDenotation "Signature",id,type']) + compileLispDefinition(id,def) + id' + + +++ Remove possible modifiers in the FFI type expression `t'. +removeModifiers t == + for (ts := [x,:.]) in tails t repeat + x is [m,t'] and m in '(ReadOnly WriteOnly) => + rplac(first ts,t') + t + +++ Compile external entity signature import. +compSignatureImport: (%Form,%Mode,%Env) -> %Maybe %Triple +compSignatureImport(["%SignatureImport",id,type,home],m,e) == + -- 1. Make sure we have the right syntax. + home isnt ["Foreign",:args] => + stackAndThrow('"signature import from be from a %1bp domain",["Foreign"]) + args isnt [lang] => + stackAndThrow('"%1bp takes exactly one argument",["Foreign"]) + not IDENTP lang => + stackAndThrow('"Argument to %1bp must be an identifier",["Foreign"]) + lang ^= "C" => + stackAndThrow('"Sorry: Only %1bp is valid at the moment",["Foreign C"]) + -- 2. Make sure this import is not subverting anything we know + id' := checkExternalEntity(id,type,lang,e) + -- 3. Make a local declaration for it. + T := compMakeDeclaration(id,removeModifiers type,e) or return nil + T.env := put(id,"%Lang",lang,T.env) + T.env:= put(id,"%Link",id',T.env) + convert(T,m) + + --% Compilation of logical operators that may have a pre-defined --% meaning, or may need special handling because or short-circuiting --% etc. @@ -2321,5 +2430,6 @@ for x in [["|", :"compSuchthat"],_ ["rep",:"compRep"],_ ["%Comma",:"compComma"],_ ["%Match",:"compMatch"],_ + ["%SignatureImport",:"compSignatureImport"],_ ["[||]", :"compileQuasiquote"]] repeat MAKEPROP(first x, "SPECIAL", rest x) diff --git a/src/interp/define.boot b/src/interp/define.boot index 6a2aecbb..42414d08 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -299,7 +299,7 @@ compDefine1(form,m,e) == null $form => stackAndThrow ['"bad == form ",form] newPrefix:= $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) + getConstructorAbbreviationFromDB $op compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) compDefineAddSignature([op,:argl],signature,e) == @@ -1492,6 +1492,9 @@ doIt(item,$predl) == item is ["%Inline",type] => processInlineRequest(type,$e) mutateToNothing item + item is ["%SignatureImport",:.] => + [.,.,$e] := compSignatureImport(item,$EmptyMode,$e) + mutateToNothing item item is ["IF",:.] => doItIf(item,$predl,$e) item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index 9867963c..3a0ffa89 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -444,15 +444,25 @@ (DEFUN |PARSE-Import| () - (AND (MATCH-ADVANCE-STRING "import") (MUST (|PARSE-Expr| 1000)) - (BANG FIL_TEST - (OPTIONAL - (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") - (MUST (|PARSE-Expr| 1000)))))) - (PUSH-REDUCTION '|PARSE-Import| - (CONS '|import| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))) + (AND (MATCH-ADVANCE-STRING "import") + (MUST (|PARSE-Expr| 1000)) + (OR (AND (MATCH-ADVANCE-STRING ":") + (MUST (|PARSE-Expression|)) + (MUST (MATCH-ADVANCE-STRING "from")) + (MUST (|PARSE-Expr| 1000)) + (PUSH-REDUCTION '|PARSE-Import| + (CONS '|%SignatureImport| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (AND (BANG FIL_TEST + (OPTIONAL + (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-Expr| 1000)))))) + (PUSH-REDUCTION '|PARSE-Import| + (CONS '|import| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))))) ;; domain inlining. Same syntax as import directive; except ;; deliberate restriction on naming one type at a time. diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 5f65c312..b792ff7e 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -1006,12 +1006,20 @@ encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) encodedPair() == n=1 => encodeItem x STRCONC(STRINGIMAGE n,encodeItem x) - encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", + encodedName:= INTERNL(getConstructorAbbreviationFromDB packageName,";", encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) if $LISPLIB then $lisplibSignatureAlist:= [[encodedName,:signature'],:$lisplibSignatureAlist] encodedName + +++ Return the linkage name of the local operation named `op'. +encodeLocalFunctionName op == + prefix := + $prefix => $prefix + $functorForm => getConstructorAbbreviationFromDB first $functorForm + stackAndThrow('"There is no context for local function %1b",[op]) + INTERN strconc(prefix,'";",encodeItem op) splitEncodedFunctionName(encodedName, sep) == -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index 32105963..1277504e 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -363,6 +363,10 @@ $Syntax == $Boolean == '(Boolean) +$Byte == '(Byte) +$Int32 == '(Int32) +$Int64 == '(Int64) + ++ The SmallInteger domain constructor form $SmallInteger == '(SingleInteger) @@ -414,7 +418,6 @@ $DoubleFloat == $BigFloat == '(Float) - ++ The String constructor domain form $String == '(String) diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index f3b49f6a..d47b763c 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -637,6 +637,10 @@ #+:CCL (proclaim '(special *vars* *decl*)) ;; declare not handled right +(defun |compileLispDefinition| (name def) + (when *COMP370-APPLY* + (funcall *COMP370-APPLY* name def))) + (defun COMPILE1 (fn) (let* (nargs (fname (car fn)) @@ -664,7 +668,7 @@ (setq body (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body)) ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body)))) - (if *COMP370-APPLY* (funcall *COMP370-APPLY* fname body)) + (|compileLispDefinition| fname body) body)) |