14 files changed, 214 insertions, 50 deletions

diff --git a/configure b/configure
index f21ccdab..27e3581b 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
 #! /bin/sh
 # Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.60 for OpenAxiom 1.3.0-2009-03-02.
+# Generated by GNU Autoconf 2.60 for OpenAxiom 1.3.0-2009-03-08.
 #
 # Report bugs to <open-axiom-bugs@lists.sf.net>.
 #
@@ -713,8 +713,8 @@ SHELL=${CONFIG_SHELL-/bin/sh}
 # Identity of this package.
 PACKAGE_NAME='OpenAxiom'
 PACKAGE_TARNAME='openaxiom'
-PACKAGE_VERSION='1.3.0-2009-03-02'
-PACKAGE_STRING='OpenAxiom 1.3.0-2009-03-02'
+PACKAGE_VERSION='1.3.0-2009-03-08'
+PACKAGE_STRING='OpenAxiom 1.3.0-2009-03-08'
 PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net'
 
 ac_unique_file="src/Makefile.pamphlet"
@@ -1406,7 +1406,7 @@ if test "$ac_init_help" = "long"; then
   # Omit some internal or obsolete options to make the list less imposing.
   # This message is too long to be a string in the A/UX 3.1 sh.
   cat <<_ACEOF
-\`configure' configures OpenAxiom 1.3.0-2009-03-02 to adapt to many kinds of systems.
+\`configure' configures OpenAxiom 1.3.0-2009-03-08 to adapt to many kinds of systems.
 
 Usage: $0 [OPTION]... [VAR=VALUE]...
 
@@ -1476,7 +1476,7 @@ fi
 
 if test -n "$ac_init_help"; then
   case $ac_init_help in
-     short | recursive ) echo "Configuration of OpenAxiom 1.3.0-2009-03-02:";;
+     short | recursive ) echo "Configuration of OpenAxiom 1.3.0-2009-03-08:";;
    esac
   cat <<\_ACEOF
 
@@ -1580,7 +1580,7 @@ fi
 test -n "$ac_init_help" && exit $ac_status
 if $ac_init_version; then
   cat <<\_ACEOF
-OpenAxiom configure 1.3.0-2009-03-02
+OpenAxiom configure 1.3.0-2009-03-08
 generated by GNU Autoconf 2.60
 
 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
@@ -1594,7 +1594,7 @@ cat >config.log <<_ACEOF
 This file contains any messages produced by compilers while
 running configure, to aid debugging if configure makes a mistake.
 
-It was created by OpenAxiom $as_me 1.3.0-2009-03-02, which was
+It was created by OpenAxiom $as_me 1.3.0-2009-03-08, which was
 generated by GNU Autoconf 2.60.  Invocation command line was
 
   $ $0 $@
@@ -26817,7 +26817,7 @@ exec 6>&1
 # report actual input values of CONFIG_FILES etc. instead of their
 # values after options handling.
 ac_log="
-This file was extended by OpenAxiom $as_me 1.3.0-2009-03-02, which was
+This file was extended by OpenAxiom $as_me 1.3.0-2009-03-08, which was
 generated by GNU Autoconf 2.60.  Invocation command line was
 
   CONFIG_FILES    = $CONFIG_FILES
@@ -26866,7 +26866,7 @@ Report bugs to <bug-autoconf@gnu.org>."
 _ACEOF
 cat >>$CONFIG_STATUS <<_ACEOF
 ac_cs_version="\\
-OpenAxiom config.status 1.3.0-2009-03-02
+OpenAxiom config.status 1.3.0-2009-03-08
 configured by $0, generated by GNU Autoconf 2.60,
   with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
 
diff --git a/configure.ac b/configure.ac
index ef263419..97344b46 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,6 +1,6 @@
 sinclude(config/open-axiom.m4)
 sinclude(config/aclocal.m4)
-AC_INIT([OpenAxiom], [1.3.0-2009-03-02], 
+AC_INIT([OpenAxiom], [1.3.0-2009-03-08], 
         [open-axiom-bugs@lists.sf.net])
 
 AC_CONFIG_AUX_DIR(config)
diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet
index 00390bdf..a8785498 100644
--- a/configure.ac.pamphlet
+++ b/configure.ac.pamphlet
@@ -1140,7 +1140,7 @@ information:
 <<Autoconf init>>=
 sinclude(config/open-axiom.m4)
 sinclude(config/aclocal.m4)
-AC_INIT([OpenAxiom], [1.3.0-2009-03-02], 
+AC_INIT([OpenAxiom], [1.3.0-2009-03-08], 
         [open-axiom-bugs@lists.sf.net])
 
 @
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"