Add support for CLozure CL.

	* lisp/core.lisp.in: Add support for Clozure CL.
	(main): Remove as unused.
	* driver/utils.h (openaxiom_runtime): Add openaxiom_clozure_runtime.
	* boot/translator.boot (loadNativeModule): Handle Clozure CL.
	* boot/ast.boot (nativeType): Handle Clozure's FFI types.
	(nativeReturnType): Likewise.
	(coerceToNativeType): Likewise.
	(genCLOZUREnativeTranslation): New.
	(genImportDeclaration): Use it.
	* interp/vmlisp.lisp (SINTP): Remove duplicate definition.
	(SMINTP): Likewise.
	(ZERO?): Likewise.
	(GCMSG): Reorganize definition.
	(BPINAME): Likewise.

2 files changed, 69 insertions, 9 deletions

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 5eb147ed..6f3e701f 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2009, Gabriel Dos Reis.
+-- Copyright (C) 2007-2010, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -1275,43 +1275,50 @@ nativeType t ==
     t in '(byte uint8) =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),8]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT8")
-      %hasFeature KEYWORD::ECL => KEYWORD::UNSIGNED_-BYTE
+      %hasFeature KEYWORD::ECL or %hasFeature KEYWORD::CLOZURE =>
+        KEYWORD::UNSIGNED_-BYTE
       nativeType "char"           -- approximate by 'char' for GCL
     t = "int16" =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),16]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT16")
       %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T =>
          KEYWORD::INT16_-T
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-HALFWORD
       unknownNativeTypeError t
     t = "uint16" =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),16]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT16")
       %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T =>
          KEYWORD::UINT16_-T
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-HALFWORD
       unknownNativeTypeError t
     t = "int32" =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),32]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32")
       %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T =>
          KEYWORD::INT32_-T
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-FULLWORD
       unknownNativeTypeError t
     t = "uint32" =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),32]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32")
       %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T =>
          KEYWORD::UINT32_-T
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-FULLWORD
       unknownNativeTypeError t
     t = "int64" =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),64]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT64")
       %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T =>
          KEYWORD::INT64_-T
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-DOUBLEWORD
       unknownNativeTypeError t
     t = "uint64" =>
       %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),64]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT64")
       %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T =>
          KEYWORD::UINT64_-T
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-DOUBLEWORD
       unknownNativeTypeError t
     t = "float32" => nativeType "float"
     t = "float64" => nativeType "double"
@@ -1320,6 +1327,7 @@ nativeType t ==
       %hasFeature KEYWORD::ECL => KEYWORD::POINTER_-VOID
       %hasFeature KEYWORD::SBCL => ["*",bfColonColon("SB-ALIEN","VOID")]
       %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER")
+      %hasFeature KEYWORD::CLOZURE => KEYWORD::ADDRESS
       unknownNativeTypeError t
     unknownNativeTypeError t
   -- composite, reference type.
@@ -1328,13 +1336,13 @@ nativeType t ==
     %hasFeature KEYWORD::ECL => KEYWORD::OBJECT
     %hasFeature KEYWORD::SBCL => ["*",nativeType second t]
     %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER")
+    %hasFeature KEYWORD::CLOZURE => [KEYWORD::_*, nativeType second t]
     unknownNativeTypeError t
   first t = "pointer" =>
     -- we don't bother looking at what the pointer points to.
     nativeType "pointer"
   unknownNativeTypeError t
 
-
 ++ Check that `t' is a valid return type for a native function, and
 ++ returns its translation
 nativeReturnType t ==
@@ -1342,7 +1350,6 @@ nativeReturnType t ==
   coreError strconc('"invalid return type for native function: ", 
               SYMBOL_-NAME t)
 
-
 ++ Check that `t' is a valid parameter type for a native function,
 ++ and returns its translation.
 nativeArgumentType t ==
@@ -1363,7 +1370,6 @@ nativeArgumentType t ==
     coreError '"expected simple native data type"
   nativeType second t
   
-
 ++ True if objects of type native type `t' are sensible to GC.
 needsStableReference? t ==
   t is [m,:.] and m in '(readonly writeonly readwrite)
@@ -1371,9 +1377,9 @@ needsStableReference? t ==
 ++ coerce argument `a' to native type `t', in preparation for
 ++ a call to a native functions.
 coerceToNativeType(a,t) ==
-  -- GCL, ECL, and CLISP don't do it this way.
+  -- GCL, ECL, CLISP, and CLOZURE don't do it this way.
   %hasFeature KEYWORD::GCL or %hasFeature KEYWORD::ECL
-     or %hasFeature KEYWORD::CLISP  => a
+     or %hasFeature KEYWORD::CLISP or %hasFeature KEYWORD::CLOZURE => a
   %hasFeature KEYWORD::SBCL =>
     not needsStableReference? t => a
     [.,[c,y]] := t
@@ -1483,7 +1489,7 @@ genCLISPnativeTranslation(op,s,t,op') ==
   parms := [GENSYM '"parm" for x in s]  -- parameters of the forward decl.
 
   -- Now, separate non-simple data from the rest.  This is a triple-list
-  -- of the form ((parameter boot-time . ffi-type) ...)
+  -- of the form ((parameter boot-type . ffi-type) ...)
   unstableArgs := nil
   for p in parms for x in s for y in argtypes repeat
     needsStableReference? x =>
@@ -1563,6 +1569,57 @@ genSBCLnativeTranslation(op,s,t,op') ==
 	  ["FUNCTION",rettype,:argtypes]], :nreverse newArgs]]]]
 
 
+
+++ Generate Clozure CL's equivalent of import declaration
+genCLOZUREnativeTranslation(op,s,t,op') ==
+  -- check parameter types and return types.
+  rettype := nativeReturnType t
+  argtypes := [nativeArgumentType x for x in s]
+
+  -- Build parameter list for the forwarding function
+  parms := [GENSYM '"parm" for x in s]
+
+  -- Separate string arguments and array arguments from scalars.
+  -- These array arguments need to be pinned down, and the string
+  -- arguments need to stored in a stack-allocaed NTBS.
+  strPairs := nil 
+  aryPairs := nil
+  for p in parms for x in s repeat
+    x = "string" => strPairs := [[p,:GENSYM '"loc"], :strPairs]
+    x is [.,["buffer",.]] => aryPairs := [[p,:GENSYM '"loc"], :aryPairs]
+
+  -- Build the actual foreign function call.
+  -- Note that Clozure CL does not mangle foreign function call for
+  -- us, so we're left with more platform dependencies than needed.
+  if %hasFeature KEYWORD::DARWIN then
+    op' := strconc("__",op')
+  call := [bfColonColon("CCL","EXTERNAL-CALL"), STRING op', :args, rettype]
+            where
+              args() == [:[x, parm] for x in argtypes for p in parms]
+              parm() ==
+                    p' := ASSOC(p, strPairs) => rest p'
+                    p' := ASSOC(p, aryPairs) => rest p'
+                    p
+
+  -- If the foreign call returns a C-string, turn it into a Lisp string.
+  -- Note that if the C-string was malloc-ed, this will leak storage.
+  if t = "string" then
+    call := [bfColonColon("CCL","GET-CSTRING"), call]
+
+  -- If we have array arguments from Boot, bind pointers to initial data.
+  for arg in aryPairs repeat
+    call := [bfColonColon("CCL", "WITH-POINTER-TO-IVECTOR"),
+              [rest arg, first arg], call]
+
+  -- Finally, if we have string arguments from Boot, copy them to
+  -- stack-allocated NTBS.
+  if strPairs ~= nil then
+    call := [bfColonColon("CCL", "WITH-CSTRS"),
+              [[rest arg, first arg] for arg in strPairs], call]
+
+  -- Finally, return the definition form
+  [["DEFUN", op, parms, call]]
+
 ++ Generate an import declaration for `op' as equivalent of the
 ++ foreign signature `sig'.  Here, `foreign' operationally means that
 ++ the entity is from the C language world. 
@@ -1575,6 +1632,7 @@ genImportDeclaration(op, sig) ==
   %hasFeature KEYWORD::SBCL => genSBCLnativeTranslation(op,s,t,op')
   %hasFeature KEYWORD::CLISP => genCLISPnativeTranslation(op,s,t,op')
   %hasFeature KEYWORD::ECL => genECLnativeTranslation(op,s,t,op')
+  %hasFeature KEYWORD::CLOZURE => genCLOZUREnativeTranslation(op,s,t,op')
   fatalError '"import declaration not implemented for this Lisp"
 
 
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index f931975e..c23debbd 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2009, Gabriel Dos Reis.
+-- Copyright (C) 2007-2010, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -771,6 +771,8 @@ loadNativeModule m ==
     EVAL [bfColonColon("FFI","DEFAULT-FOREIGN-LIBRARY"), m]
   %hasFeature KEYWORD::ECL =>
     EVAL [bfColonColon("FFI","LOAD-FOREIGN-LIBRARY"), m]
+  %hasFeature KEYWORD::CLOZURE =>
+    EVAL [bfColonColon("CCL","OPEN-SHARED-LIBRARY"), m]
   coreError '"don't know how to load a dynamically linked module"
 
 loadSystemRuntimeCore() ==