* 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.

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))