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.

7 files changed, 154 insertions, 107 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 65af692f..0c6ab682 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,23 @@
 2010-02-07  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	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.
+
+2010-02-07  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/daase.lisp: Remove conditionals on :CCL.
 	* interp/fname.lisp: Likewise.
 	* interp/foam_l.lisp: Likewise.
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() ==
diff --git a/src/driver/utils.h b/src/driver/utils.h
index 89aa81aa..83c168ae 100644
--- a/src/driver/utils.h
+++ b/src/driver/utils.h
@@ -1,5 +1,5 @@
 /*
-   Copyright (C) 2008-2009, Gabriel Dos Reis.
+   Copyright (C) 2008-2010, Gabriel Dos Reis.
    All rights reserved.
 
    Redistribution and use in source and binary forms, with or without
@@ -60,6 +60,7 @@ typedef enum openaxiom_runtime {
    openaxiom_sbcl_runtime,
    openaxiom_clisp_runtime,
    openaxiom_ecl_runtime,
+   openaxiom_clozure_runtime,
    openaxiom_bemol_runtime
 } openaxiom_runtime;
 
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index e17d6f65..b2d70fd2 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -2380,7 +2380,7 @@ savesystem l ==
 )if not %hasFeature KEYWORD::ECL
   AxiomCore::saveCore SYMBOL_-NAME first l
 )else
-  fatalError '"don't know how to same image"
+  fatalError '"don't know how to save image"
 )endif
 
 --% )show
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index e7bedb34..811b7069 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -469,15 +469,9 @@
 (defmacro sintp (n)
  `(typep ,n 'fixnum))
 
-(defmacro sintp (n)
-  `(fixp ,n))
-
 (defmacro smintp (n)
  `(typep ,n 'fixnum))
 
-(defmacro smintp (n)
-  `(fixp ,n))
-
 (defmacro stringlength (x)
  `(length (the string ,x)))
 
@@ -498,8 +492,6 @@
 (defmacro zero? (x)
   `(and (typep ,x 'fixnum) (zerop (the fixnum ,x))))
 
-(defmacro zero? (x) `(zerop ,x))
-
 ;; defuns
 
 (define-function 'tempus-fugit #'get-internal-run-time)
@@ -1693,66 +1685,57 @@
 (defun |read-line| (st &optional (eofval *read-place-holder*))
   (read-line st nil eofval))
 
-#+Lucid
-(defun gcmsg (x)
-   (prog1 (not system::*gc-silence*) (setq system::*gc-silence* (not x))))
-#+(OR IBCL KCL)
-(defun gcmsg (x)
-   (prog1 system:*gbc-message* (setq system:*gbc-message* x)))
-#+:cmulisp
 (defun gcmsg (x)
-   (prog1 ext:*gc-verbose* (setq ext:*gc-verbose* x)))
-#+ (or :allegro :sbcl :clisp :ecl)
-(defun gcmsg (x))
-
-#+Lucid
-(defun reclaim () (system:gc))
-#+:cmulisp
-(defun reclaim () (ext:gc))
-#+(OR IBCL KCL)
-(defun reclaim () (gbc t))
-#+:allegro
-(defun reclaim () (excl::gc t))
+  #+Lucid
+  (prog1 (not system::*gc-silence*) 
+    (setq system::*gc-silence* (not x)))
+  #+(OR IBCL KCL)
+  (prog1 system:*gbc-message* 
+    (setq system:*gbc-message* x))
+  #+:cmulisp
+  (prog1 ext:*gc-verbose* 
+    (setq ext:*gc-verbose* x))
+  )
+
+(defun reclaim ()
+  #+Lucid (system:gc)
+  #+:cmulisp (ext:gc)
+  #+(OR IBCL KCL) (gbc t)
+  #+:allegro (excl::gc t)
+  )
 
-#+Lucid
-(defun BPINAME (func)
-  (if (functionp func)
-      (if (symbolp func) func
-        (let ((name (svref func 0)))
-          (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA))
-              (cadr name)
-            name)) )))
-
-#+(OR IBCL KCL)
-(defun BPINAME (func)
-  (if (functionp func)
-      (cond ((symbolp func) func)
-            ((and (consp func) (eq (car func) 'LAMBDA-BLOCK))
-              (cadr func))
-            ((compiled-function-p func)
-             (system:compiled-function-name func))
-            ('t func))))
-#+:cmulisp
-(defun BPINAME (func)
- (when (functionp func)
-  (cond
-    ((symbolp func) func)
-    ((and (consp func) (eq (car func) 'lambda)) (second (third func)))
-    ((compiled-function-p func)
-      (system::%primitive header-ref func system::%function-name-slot))
-    ('else func))))
-#+:allegro
 (defun bpiname (func)
- func)
-
-#+(or :SBCL :clisp :ecl)
-(defun BPINAME (x)
-  (if (symbolp x)
-      x
-    (multiple-value-bind (l c n)
-      (function-lambda-expression x)
-      (declare (ignore l c))
-      n)))
+  #+Lucid (if (functionp func)
+	      (if (symbolp func) func
+		(let ((name (svref func 0)))
+		  (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA))
+		      (cadr name)
+		    name))))
+
+  #+(OR IBCL KCL) (if (functionp func)
+		      (cond ((symbolp func) func)
+			    ((and (consp func) (eq (car func) 'LAMBDA-BLOCK))
+			     (cadr func))
+			    ((compiled-function-p func)
+			     (system:compiled-function-name func))
+			    ('t func)))
+  #+:cmulisp (when (functionp func)
+	       (cond
+		((symbolp func) func)
+		((and (consp func) 
+		      (eq (car func) 'lambda)) 
+		 (second (third func)))
+		((compiled-function-p func)
+		 (system::%primitive header-ref func
+				     system::%function-name-slot))
+		('else func)))
+  #+:allegro func
+  #+(or :SBCL :clisp :ecl :clozure) (if (symbolp func)
+			       func
+			     (multiple-value-bind (l c n)
+                                 (function-lambda-expression func)
+				 (declare (ignore l c))
+				 n)))
 
   
 (defun RE-ENABLE-INT (number-of-handler) number-of-handler)
diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in
index d12723b4..1d4882ad 100644
--- a/src/lisp/core.lisp.in
+++ b/src/lisp/core.lisp.in
@@ -3,7 +3,7 @@
 ;; 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
@@ -190,7 +190,9 @@
   #+:ecl #'si::top-level
   #+:gcl #'si::top-level
   #+:sbcl #'sb-impl::toplevel-init
-  #+clisp #'system::main-loop)
+  #+clisp #'system::main-loop
+  #+:clozure nil			; don't know, kept private
+  )
 
 ;; Lisp source file extension.
 (defconstant |$LispFileType| "lisp")
@@ -404,7 +406,6 @@
                           option)))))
     (values options-so-far argv)))
 
-
 ;; 
 ;; -*- Building New Lisp Images -*-
 ;; 
@@ -468,6 +469,12 @@
                                  :norc t
                                  ))
              (ext::quit))
+  #+:clozure (progn
+	       (ccl:save-application core-image
+				     :toplevel-function entry-point
+				     :error-handler :quit
+				     :prepend-kernel t)
+	       (return-from |saveCore|))
   (error "don't know how to save Lisp image"))
 
 
@@ -489,7 +496,8 @@
   #+:clisp (ext:quit status)
   #+:gcl (si::bye status)
   #+:ecl (ext:quit status)
-  #-(or :sbcl :clisp :gcl :ecl) 
+  #+:clozure (ccl:quit status)
+  #-(or :sbcl :clisp :gcl :ecl :clozure) 
   (error "`coreQuit' not implemented for this Lisp"))
 
 
@@ -592,9 +600,10 @@
 ;; Command line arguments: equivalent of traditional `argv[]' from
 ;;  systems programming world.
 (defun |getCommandLineArguments| nil
-  #-(or :gcl :sbcl :clisp :ecl) 
+  #-(or :gcl :sbcl :clisp :ecl :clozure) 
   (|fatalError| "don't know how to get command line args")
   (let* ((all-args  
+	  #+:clozure ccl:*command-line-argument-list*
           #+:ecl (ext:command-args)
           #+:gcl si::*command-args*
           #+:sbcl sb-ext::*posix-argv*
@@ -604,31 +613,6 @@
 
 
 ;; 
-;; -*- Program Startup -*-
-;; 
-
-;; The top level entry point to most saved Lisp image.
-(defun |main| nil
-  (setq *package* (find-package "BOOT"))
-  ;; Existing system programming practive, and POSIX, have it
-  ;; that the first argument on the command line is the name
-  ;; of the current instantiation of the program.
-  ;; We require at least two arguments:
-  ;;    (0) the program name
-  ;;    (1) either one of --help or --version, or
-  ;;        a filename.
-  (let ((command-args (|getCommandLineArguments|)))
-    (when (null command-args) 
-      (|internalError| "empty command line args"))
-    (when (fboundp '|main|)
-      (|coreQuit| (funcall '|main| command-args)))
-
-    ;; Huh, the main entry point was not defined.
-    (|fatalError| "missing definition for main function")
-    (|coreQuit| 1)))
-
-
-;; 
 ;; -*- Building Standalone Executable -*-
 ;; 
 ;; Build a standalone excutable from LISP-FILES -- a list of
@@ -715,6 +699,7 @@
 
 )
 
+
 ;; 
 ;; -*- --help Handler -*-
 ;; 
@@ -887,7 +872,7 @@
                         
      ;; Run the system-specific initialization.
      (when (fboundp '|%sysInit|)
-       (funcall '|%sysInit|))
+       (funcall (symbol-function '|%sysInit|)))
      
      (when (|handleCommandLine| (car command-args) options args)
        (|coreQuit| (if (> (|errorCount|) 0) 1 0))))))