From 2da25f5f77b5e1b500ced33c51166dff7a43338d Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sun, 8 Mar 2009 17:50:45 +0000
Subject: * interp/fnewmeta.lisp (PARSE-Import): Parse extern entity
signature import. * interp/functor.boot (encodeLocalFunctionName): New.
* interp/define.boot (compDefine1): Avoid getAbbreviation. (doIt): Handle
%SignatureImport nodes. * interp/compiler.boot (emitLocalCallInsn):
New. (applyMapping): Use it. (compApplication): Likewise.
(bootDenotation): New. (getBasicFFIType): Likewise.
(getFFIDatatype): Likewise. (getBootType): Likewise.
(checkExternalEntityType): Likewise. (checkExternalEntity): Likewise.
(removeModifiers): Likewise. (compSignatureImport): Likewise. *
interp/vmlisp.lisp (|compileLispDefinition|): New. *
interp/boot-pkg.lisp: Import genImportDeclaration. *
boot/initial-env.lisp: Export genImportDeclaration. * boot/ast.boot: Tidy.
Accept `readwrite' modifier.
---
src/ChangeLog | 23 ++++++++
src/boot/ast.boot | 20 +++----
src/boot/initial-env.lisp | 5 +-
src/interp/boot-pkg.lisp | 5 +-
src/interp/compiler.boot | 132 ++++++++++++++++++++++++++++++++++++++----
src/interp/define.boot | 5 +-
src/interp/fnewmeta.lisp | 28 ++++++---
src/interp/functor.boot | 10 +++-
src/interp/sys-constants.boot | 5 +-
src/interp/vmlisp.lisp | 6 +-
src/lisp/core.lisp.in | 3 +-
11 files changed, 203 insertions(+), 39 deletions(-)
(limited to 'src')
diff --git a/src/ChangeLog b/src/ChangeLog
index 06cd80b8..192e1f26 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,26 @@
+2009-03-08 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/fnewmeta.lisp (PARSE-Import): Parse extern entity
+ signature import.
+ * interp/functor.boot (encodeLocalFunctionName): New.
+ * interp/define.boot (compDefine1): Avoid getAbbreviation.
+ (doIt): Handle %SignatureImport nodes.
+ * interp/compiler.boot (emitLocalCallInsn): New.
+ (applyMapping): Use it.
+ (compApplication): Likewise.
+ (bootDenotation): New.
+ (getBasicFFIType): Likewise.
+ (getFFIDatatype): Likewise.
+ (getBootType): Likewise.
+ (checkExternalEntityType): Likewise.
+ (checkExternalEntity): Likewise.
+ (removeModifiers): Likewise.
+ (compSignatureImport): Likewise.
+ * interp/vmlisp.lisp (|compileLispDefinition|): New.
+ * interp/boot-pkg.lisp: Import genImportDeclaration.
+ * boot/initial-env.lisp: Export genImportDeclaration.
+ * boot/ast.boot: Tidy. Accept `readwrite' modifier.
+
2009-03-02 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/compiler.boot (modeIsAggregateOf): Use RepIfRepHack.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 270b1221..819f79d4 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1249,9 +1249,9 @@ genTypeAlias(head,body) ==
-- This is used to communicate data between native
-- functions and OpenAxiom functions. The `buffer' type
-- constructor must be used in conjunction with one of the
--- modifier `readonly' or `writeonly', and instantiated
--- with one of `char', `byte', `int', `float', and `double'.
--- It cannot be used a function return type.
+-- modifiers `readonly', `writeonly', or `readwrite', and
+-- instantiated with one of `char', `byte', `int', `float',
+-- and `double'. It cannot be used as function return type.
-- Note that the length of the array is not stored as
-- part of the data being transmitted.
@@ -1327,7 +1327,7 @@ nativeArgumentType t ==
coreError '"invalid argument type for a native function"
[m,[c,t']] := t
-- Require a modifier.
- not (m in '(readonly writeonly)) =>
+ not (m in '(readonly writeonly readwrite)) =>
coreError '"missing modifier for argument type for a native function"
-- Only 'pointer' and 'buffer' can be instantiated.
not (c in '(buffer pointer)) =>
@@ -1339,7 +1339,7 @@ nativeArgumentType t ==
++ True if objects of type native type `t' are sensible to GC.
needsStableReference? t ==
- not atom t and first t in '(readonly writeonly)
+ not atom t and first t in '(readonly writeonly readwrite)
++ coerce argument `a' to native type `t', in preparation for
++ a call to a native functions.
@@ -1471,9 +1471,9 @@ genCLISPnativeTranslation(op,s,t,op') ==
[KEYWORD::LANGUAGE,KEYWORD::STDC]]
-- The forwarding function. We have to introduce local foreign
- -- variables to hold the address of converted Lisp obejcts. Then
- -- we have to copy back those that are `writeonly' to simulate
- -- the reference semantics. Don't try ever try to pass around
+ -- variables to hold the address of converted Lisp objects. Then
+ -- we have to copy back those that are `writeonly' or `readwrite' to
+ -- simulate the reference semantics. Don't ever try to pass around
-- gigantic buffer, you might find out that it is insanely inefficient.
forwardingFun :=
null unstableArgs => ["DEFUN",op,parms, [n,:parms]]
@@ -1483,11 +1483,11 @@ genCLISPnativeTranslation(op,s,t,op') ==
actualArg(p,pairs) ==
a' := rest ASSOC(p,pairs) => rest rest a'
p
- -- Fix up the call if there is any `writeonly' parameter.
+ -- Fix up the call if there is any `write' parameter.
call :=
fixups := [q | not null (q := copyBack p) for p in localPairs] where
copyBack [p,x,y,:a] ==
- x isnt ["writeonly",:.] => nil
+ x is ["readonly",:.] => nil
["SETF", p, [bfColonColon("FFI","FOREIGN-VALUE"), a]]
null fixups => [call]
[["PROG1",call, :fixups]]
diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp
index 7c98e734..dd67e0c4 100644
--- a/src/boot/initial-env.lisp
+++ b/src/boot/initial-env.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
@@ -49,7 +49,8 @@
(:export "loadNativeModule"
"loadSystemRuntimeCore"
"$InteractiveMode"
- "string2BootTree"))
+ "string2BootTree"
+ "genImportDeclaration"))
(in-package "BOOTTRAN")
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))
diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in
index f4f9fa15..de5eea6d 100644
--- a/src/lisp/core.lisp.in
+++ b/src/lisp/core.lisp.in
@@ -540,7 +540,8 @@
(reduce #'(lambda (x y)
(concatenate 'string x y))
msg :initial-value ""))
- (t msg))))
+ (t msg)))
+ nil)
(defun |warn| (msg)
(|diagnosticMessage| "warning"
--
cgit v1.2.3