From 3f8f61e055c818711c6a6136b89b6e9fedda8c3c Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Mon, 8 Feb 2010 01:08:42 +0000
Subject: 	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.

---
 src/interp/i-syscmd.boot |   2 +-
 src/interp/vmlisp.lisp   | 113 ++++++++++++++++++++---------------------------
 2 files changed, 49 insertions(+), 66 deletions(-)

(limited to 'src/interp')

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)
-- 
cgit v1.2.3