Add support for SBCL and CLisp

3 files changed, 74 insertions, 19 deletions

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 112236b6..ba6c3d1d 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -15,7 +15,7 @@
 --       the documentation and/or other materials provided with the
 --       distribution.
 --
---     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--     - Neither the name of The Numerical Algorithms Group Ltd. nor the
 --       names of its contributors may be used to endorse or promote products
 --       derived from this software without specific prior written permission.
 --
@@ -130,8 +130,10 @@ bfListOf x==x
 bfColon: %Thing -> %List
 bfColon x== ["COLON",x]
 
-bfColonColon: (%Thing,%Symbol) -> %Symbol
+bfColonColon: (%Symbol,%Symbol) -> %Symbol
 bfColonColon(package, name) == 
+  %hasFeature KEYWORD::CLISP and package in '(EXT FFI) =>
+    FIND_-SYMBOL(SYMBOL_-NAME name,package)
   INTERN(SYMBOL_-NAME name, package)
 
 bfSymbol: %Thing -> %Thing 
diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp
index d256e7c4..2e126843 100644
--- a/src/boot/initial-env.lisp
+++ b/src/boot/initial-env.lisp
@@ -1,4 +1,4 @@
-;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 ;; All rights reserved.
 ;; Copyright (C) 2007-2008, Gabriel Dos Reis.
 ;; All rights reserved.
@@ -15,7 +15,7 @@
 ;;       the documentation and/or other materials provided with the
 ;;       distribution.
 ;;
-;;     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+;;     - Neither the name of The Numerical Algorithms Group Ltd. nor the
 ;;       names of its contributors may be used to endorse or promote products
 ;;       derived from this software without specific prior written permission.
 ;;
@@ -45,8 +45,11 @@
 (defpackage "BOOTTRAN"
   (:use "AxiomCore")
   #+:common-lisp  (:use "COMMON-LISP")
-  #-:common-lisp  (:use "LISP"))
-
+  #-:common-lisp  (:use "LISP")
+  (:export "systemRootDirectory" 
+	   "systemLibraryDirectory"
+	   "loadNativeModule"
+	   "loadSystemRuntimeCore"))
 
 (in-package "BOOTTRAN")
 
@@ -70,11 +73,6 @@
 (defun MAKE-VEC (n) 
   (make-array n))
 
-(defun concat (&rest l)
-  (progn
-    (setq l (mapcar #'string l))
-    (apply #'concatenate 'string l)))
-
 (defun |shoeInputFile| (filespec )
   (open filespec :direction :input :if-does-not-exist nil))
 
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 26c37e4e..d5020cf2 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -1,4 +1,4 @@
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
 -- Copyright (C) 2007-2008, Gabriel Dos Reis.
 -- All rights reserved.
@@ -15,7 +15,7 @@
 --       the documentation and/or other materials provided with the
 --       distribution.
 --
---     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--     - Neither the name of The Numerical Algorithms Group Ltd. nor the
 --       names of its contributors may be used to endorse or promote products
 --       derived from this software without specific prior written permission.
 --
@@ -323,14 +323,30 @@ genImportDeclaration(op, sig) ==
   m isnt ["Mapping", t, s] => coreError '"invalid function type"
   if not null s and SYMBOLP s then s := [s]
   %hasFeature KEYWORD::GCL => 
-    ["DEFENTRY", op, [nativeType x for x in s], 
-       [nativeType t, SYMBOL_-NAME op']]
+    [["DEFENTRY", op, [nativeType x for x in s], 
+       [nativeType t, SYMBOL_-NAME op']]]
+  args := [GENSYM() for x in s]
   %hasFeature KEYWORD::SBCL =>
-    args := [GENSYM() for x in s]
-    ["DEFUN",op,args,
+    [["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]]
+          ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :args]]]
+  %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, 
+	    bfColonColon("FFI", nativeType x)] for x in s for a in args]],
+	      [KEYWORD::RETURN_-TYPE,bfColonColon("FFI",nativeType t)],
+		[KEYWORD::LANGUAGE,KEYWORD::STDC]]
+    forwardingFun := ["DEFUN",op,args,[n,:args]]
+    [foreignDecl,forwardingFun]
   fatalError '"import declaration not implemented for this Lisp"
 
 shoeOutParse stream ==
@@ -400,7 +416,7 @@ bpOutItem()==
         bpPush [["IMPORT-MODULE", m]]
 
       ImportSignature(x, sig) =>
-        bpPush [genImportDeclaration(x, sig)]
+        bpPush genImportDeclaration(x, sig)
 
       TypeAlias(t, args, rhs) => 
         bpPush [["DEFTYPE", t, args, ["QUOTE", rhs]]]
@@ -782,3 +798,42 @@ associateRequestWithFileType(Option '"translate", '"boot",
                              function translateBootFile)
 associateRequestWithFileType(Option '"compile", '"boot", 
                              function compileBootHandler)
+
+--% System wide properties
+
+++ Returns the root directory of the running system.
+++ A directory specified on command line takes precedence
+++ over directory specified at configuration time.
+systemRootDirectory() ==
+  dir := ASSOC(Option '"system", %systemOptions()) =>
+    ensureTrailingSlash cdr dir
+  $systemInstallationDirectory
+
+++ Returns the directory containing the core runtime support
+++ libraries, either as specified on command line, or as inferred
+++ from the system root directory.
+
+systemLibraryDirectory() ==
+  dir := ASSOC(Option "syslib",%systemOptions()) =>
+    ensureTrailingSlash rest dir
+  strconc(systemRootDirectory(),'"lib/")
+
+
+--% Runtime support
+
+++ Load native dynamically linked module
+loadNativeModule m ==
+  %hasFeature KEYWORD::SBCL =>
+    FUNCALL(bfColonColon("SB-ALIEN","LOAD-SHARED-OBJECT"),m)
+  %hasFeature KEYWORD::CLISP =>
+    EVAL [bfColonColon("FFI","DEFAULT-FOREIGN-LIBRARY"), m]
+  systemError '"don't know how to load a dynamically linked module"
+
+
+$OpenAxiomCoreModuleLoaded := false
+
+loadSystemRuntimeCore() ==
+  $OpenAxiomCoreModuleLoaded => nil
+  loadNativeModule strconc(systemLibraryDirectory(),
+    '"libopen-axiom-core.so")
+  $OpenAxiomCoreModuleLoaded := true