From ehuelsmann at common-lisp.net  Thu Jan  1 14:57:28 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 01 Jan 2009 14:57:28 +0000
Subject: [armedbear-cvs] r11520 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LIOzI-0006qP-B8@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan  1 14:57:27 2009
New Revision: 11520

Log:
Make the compiler recognize subtypes while compiling THE forms.

Note: Because SUBTYPEP isn't compatible with compiler-types, SUBTYPEP isn't good enough here.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Jan  1 14:57:27 2009
@@ -7905,7 +7905,7 @@
            ;; signals an error if the slot's value is not a fixnum.
            (compile-form value-form target representation))
           ((and (> *safety* 0)
-                (not (subtypep (derive-type value-form) type-form)))
+                (not (compiler-subtypep (derive-type value-form) type-form)))
            (compile-form value-form 'stack nil)
            (generate-type-check-for-value type-form)
            ;; The value is left on the stack here if the type check succeeded.



From vvoutilainen at common-lisp.net  Fri Jan  2 15:23:26 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Fri, 02 Jan 2009 15:23:26 +0000
Subject: [armedbear-cvs] r11521 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LIlry-0006k8-Bn@common-lisp.net>

Author: vvoutilainen
Date: Fri Jan  2 15:23:25 2009
New Revision: 11521

Log:
Helper macro for derive-compiler type, when checking
for parameter types in derive-type-minus, derive-type-plus,
derive-type-times, derive-type-min and derive-type-ash.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Jan  2 15:23:25 2009
@@ -6108,32 +6108,55 @@
         (return-from derive-type-%ldb (list 'INTEGER 0 (1- (expt 2 size-arg)))))))
   (list 'INTEGER 0 '*))
 
+(defmacro when-args-integer (args typenames decls &body body)
+  "Checks types of the args provided, if all args are
+integer, splits them into high/low bytes and invokes the body.
+
+args contains the arguments for which the type check is done.
+typenames contains names of variables to which the type, low byte
+and high byte of the provided arg is stored, to be used in
+the body.
+decls contains declarations used in the body, similar to let.
+body is the body to invoke. "
+  (labels ((build-let-when (body args typenames)
+	   (when args
+	     (let ((type (third typenames))
+		   (low (second typenames))
+		   (high (first typenames)))
+	       (setf body 
+		     `(let ((,type (derive-compiler-type ,(first args))))
+			(when (integer-type-p ,type)
+			  (let ((,low (integer-type-low ,type))
+				(,high (integer-type-high ,type)))
+			    ,body)))))
+	     (let ((tmpbody 
+		    (build-let-when body (cdr args) (cdddr typenames))))
+	       (if tmpbody
+		   tmpbody
+		   body)))))
+    (build-let-when 
+     `(let (, at decls) , at body)
+     (reverse args) (reverse typenames))))
+
 (defknown derive-type-minus (t) t)
 (defun derive-type-minus (form)
   (let ((args (cdr form))
         (result-type t))
     (case (length args)
       (1
-       (let ((type1 (derive-compiler-type (%car args))))
-         (when (integer-type-p type1)
-           (let* ((low1 (integer-type-low type1))
-                  (high1 (integer-type-high type1))
-                  (low (and high1 (- high1)))
-                  (high (and low1 (- low1))))
-             (setf result-type (%make-integer-type low high))))))
+       (when-args-integer 
+	((%car args))
+	(type1 low1 high1)
+	((low (and high1 (- high1)))
+	 (high (and low1 (- low1))))
+	(setf result-type (%make-integer-type low high))))
       (2
-       (let ((type1 (derive-compiler-type (%car args))))
-         (when (integer-type-p type1)
-           (let ((type2 (derive-compiler-type (%cadr args))))
-             (when (integer-type-p type2)
-               ;; Both integer types.
-               (let* ((low1 (integer-type-low type1))
-                      (high1 (integer-type-high type1))
-                      (low2 (integer-type-low type2))
-                      (high2 (integer-type-high type2))
-                      (low (and low1 high2 (- low1 high2)))
-                      (high (and high1 low2 (- high1 low2))))
-                 (setf result-type (%make-integer-type low high)))))))))
+       (when-args-integer 
+	((%car args) (%cadr args))
+	(type1 low1 high1 type2 low2 high2)
+	((low (and low1 high2 (- low1 high2)))
+	 (high (and high1 low2 (- high1 low2))))
+	(setf result-type (%make-integer-type low high)))))
     result-type))
 
 (defknown derive-type-plus (t) t)
@@ -6141,18 +6164,12 @@
   (let ((args (cdr form))
         (result-type t))
     (when (= (length args) 2)
-      (let ((type1 (derive-compiler-type (%car args))))
-        (when (integer-type-p type1)
-          (let ((type2 (derive-compiler-type (%cadr args))))
-            (when (integer-type-p type2)
-              ;; Both integer types.
-              (let* ((low1 (integer-type-low type1))
-                     (high1 (integer-type-high type1))
-                     (low2 (integer-type-low type2))
-                     (high2 (integer-type-high type2))
-                     (low (and low1 low2 (+ low1 low2)))
-                     (high (and high1 high2 (+ high1 high2))))
-                (setf result-type (%make-integer-type low high))))))))
+      (when-args-integer 
+       ((%car args) (%cadr args))
+       (type1 low1 high1 type2 low2 high2)
+       ((low (and low1 low2 (+ low1 low2)))
+	(high (and high1 high2 (+ high1 high2))))
+       (setf result-type (%make-integer-type low high))))
     result-type))
 
 (defun derive-type-times (form)
@@ -6164,32 +6181,26 @@
         (when (and (integerp arg1) (integerp arg2))
           (let ((n (* arg1 arg2)))
             (return-from derive-type-times (%make-integer-type n n))))
-      (let ((type1 (derive-compiler-type arg1)))
-        (when (integer-type-p type1)
-          (let ((type2 (derive-compiler-type arg2)))
-            (when (integer-type-p type2)
-              ;; Both integer types.
-              (let ((low1 (integer-type-low type1))
-                    (high1 (integer-type-high type1))
-                    (low2 (integer-type-low type2))
-                    (high2 (integer-type-high type2))
-                    (low nil)
-                    (high nil))
-                (cond ((not (and low1 low2))
-                       ;; Nothing to do.
-                       )
-                      ((or (minusp low1) (minusp low2))
-                       (when (and high1 high2)
-                         (let ((max (* (max (abs low1) (abs high1))
-                                       (max (abs low2) (abs high2)))))
-                           (setf low (- max)
-                                 high max))))
-                      (t
-                       (setf low (* low1 low2))
-                       (when (and high1 high2)
-                         (setf high (* high1 high2)))))
-                (setf result-type (%make-integer-type low high)))))))))
-    result-type))
+	(when-args-integer 
+	 (arg1 arg2)
+	 (type1 low1 high1 type2 low2 high2)
+	 ((low nil)
+		(high nil))
+	 (cond ((not (and low1 low2))
+		;; Nothing to do.
+		)
+	       ((or (minusp low1) (minusp low2))
+		(when (and high1 high2)
+		  (let ((max (* (max (abs low1) (abs high1))
+				(max (abs low2) (abs high2)))))
+		    (setf low (- max)
+			  high max))))
+	       (t
+		(setf low (* low1 low2))
+		(when (and high1 high2)
+		  (setf high (* high1 high2)))))
+	 (setf result-type (%make-integer-type low high)))))
+  result-type))
 
 (declaim (ftype (function (t) t) derive-type-max))
 (defun derive-type-max (form)
@@ -6202,23 +6213,17 @@
   (let ((args (cdr form))
         (result-type t))
     (when (= (length form) 3)
-      (let* ((type1 (derive-compiler-type (%car args))))
-        (when (integer-type-p type1)
-          (let ((type2 (derive-compiler-type (%cadr args))))
-            (when (integer-type-p type2)
-              ;; Both integer types.
-              (let ((low1 (integer-type-low type1))
-                    (high1 (integer-type-high type1))
-                    (low2 (integer-type-low type2))
-                    (high2 (integer-type-high type2))
-                    low high)
-                (setf low (if (and low1 low2)
-                              (min low1 low2)
-                              nil)
-                      high (if (and high1 high2)
-                               (min high1 high2)
-                               nil))
-                (setf result-type (%make-integer-type low high))))))))
+      (when-args-integer 
+       ((%car args) (%cadr args))
+       (type1 low1 high1 type2 low2 high2)
+       (low high)
+       (setf low (if (and low1 low2)
+		     (min low1 low2)
+		     nil)
+	     high (if (and high1 high2)
+		      (min high1 high2)
+		      nil))
+       (setf result-type (%make-integer-type low high))))
     result-type))
 
 ;; read-char &optional input-stream eof-error-p eof-value recursive-p => char
@@ -6234,35 +6239,32 @@
   (let* ((args (cdr form))
          (arg1 (first args))
          (arg2 (second args))
-         (type1 (derive-compiler-type arg1))
-         (type2 (derive-compiler-type arg2))
          (result-type 'INTEGER))
-    (when (and (integer-type-p type1) (integer-type-p type2))
-      (let ((low1 (integer-type-low type1))
-            (high1 (integer-type-high type1))
-            (low2 (integer-type-low type2))
-            (high2 (integer-type-high type2)))
-        (when (and low1 high1 low2 high2)
-          (cond ((fixnum-constant-value type2)
-                 (setf arg2 (fixnum-constant-value type2))
-                 (cond ((<= -64 arg2 64)
-                        (setf result-type
-                              (list 'INTEGER (ash low1 arg2) (ash high1 arg2))))
-                       ((minusp arg2)
-                        (setf result-type
-                              (list 'INTEGER
-                                    (if (minusp low1) -1 0)
-                                    (if (minusp high1) -1 0))))))
-                ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0))
-                 ;; Everything is non-negative.
-                 (setf result-type (list 'INTEGER
-                                         (ash low1 low2)
-                                         (ash high1 high2))))
-                ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
-                 ;; Negative (or zero) second argument.
-                 (setf result-type (list 'INTEGER
-                                         (ash low1 low2)
-                                         (ash high1 high2))))))))
+    (when-args-integer 
+     (arg1 arg2)
+     (type1 low1 high1 type2 low2 high2)
+     ()
+     (when (and low1 high1 low2 high2)
+       (cond ((fixnum-constant-value type2)
+	      (setf arg2 (fixnum-constant-value type2))
+	      (cond ((<= -64 arg2 64)
+		     (setf result-type
+			   (list 'INTEGER (ash low1 arg2) (ash high1 arg2))))
+		    ((minusp arg2)
+		     (setf result-type
+			   (list 'INTEGER
+				 (if (minusp low1) -1 0)
+				 (if (minusp high1) -1 0))))))
+	     ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0))
+	      ;; Everything is non-negative.
+	      (setf result-type (list 'INTEGER
+				      (ash low1 low2)
+				      (ash high1 high2))))
+	     ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
+	      ;; Negative (or zero) second argument.
+	      (setf result-type (list 'INTEGER
+				      (ash low1 low2)
+				      (ash high1 high2)))))))
     (make-compiler-type result-type)))
 
 (defknown derive-type (t) t)



From vvoutilainen at common-lisp.net  Fri Jan  2 16:36:06 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Fri, 02 Jan 2009 16:36:06 +0000
Subject: [armedbear-cvs] r11522 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LIn0I-0001A0-02@common-lisp.net>

Author: vvoutilainen
Date: Fri Jan  2 16:36:05 2009
New Revision: 11522

Log:
Helper function for p2-flet-process-compiland and
p2-labels-process-compiland.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Jan  2 16:36:05 2009
@@ -4751,6 +4751,21 @@
   (setf (compiland-class-file compiland) class-file)
   (compile-and-write-to-file class-file compiland))
 
+
+(defun emit-make-compiled-closure-for-flet/labels (local-function compiland g)
+  (emit 'getstatic *this-class* g +lisp-object+)
+  (let ((parent (compiland-parent compiland)))
+    (when (compiland-closure-register parent)
+      (dformat t "(compiland-closure-register parent) = ~S~%"
+	       (compiland-closure-register parent))
+      (emit 'checkcast +lisp-ctf-class+)
+      (aload (compiland-closure-register parent))
+      (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+			 (list +lisp-object+ +lisp-object-array+)
+			 +lisp-object+)))
+  (emit 'var-set (local-function-variable local-function)))
+
+
 (defknown p2-flet-process-compiland (t) t)
 (defun p2-flet-process-compiland (local-function)
   (let* ((compiland (local-function-compiland local-function))
@@ -4768,20 +4783,8 @@
 
            (when (local-function-variable local-function)
              (let ((g (declare-local-function local-function)))
-               (emit 'getstatic *this-class* g +lisp-object+)
-
-               (let ((parent (compiland-parent compiland)))
-                 (when (compiland-closure-register parent)
-                   (dformat t "(compiland-closure-register parent) = ~S~%"
-                            (compiland-closure-register parent))
-                   (emit 'checkcast +lisp-ctf-class+)
-                   (aload (compiland-closure-register parent))
-                   (emit-invokestatic +lisp-class+ "makeCompiledClosure"
-                                      (list +lisp-object+ +lisp-object-array+)
-                                      +lisp-object+)))
-
-               (dformat t "p2-flet-process-compiland var-set ~S~%" (variable-name (local-function-variable local-function)))
-               (emit 'var-set (local-function-variable local-function)))))
+	       (emit-make-compiled-closure-for-flet/labels 
+		local-function compiland g))))
           (t
            (let* ((pathname (make-temp-file))
                   (class-file (make-class-file :pathname pathname
@@ -4794,20 +4797,9 @@
 
                    (when (local-function-variable local-function)
                      (let ((g (declare-object (load-compiled-function pathname))))
-                       (emit 'getstatic *this-class* g +lisp-object+)
-
-                       (let ((parent (compiland-parent compiland)))
-                         (when (compiland-closure-register parent)
-                           (dformat t "(compiland-closure-register parent) = ~S~%"
-                                    (compiland-closure-register parent))
-                           (emit 'checkcast +lisp-ctf-class+)
-                           (aload (compiland-closure-register parent))
-                           (emit-invokestatic +lisp-class+ "makeCompiledClosure"
-                                              (list +lisp-object+ +lisp-object-array+)
-                                              +lisp-object+)))
-
-                       (emit 'var-set (local-function-variable local-function)))))
-               (delete-file pathname)))))))
+		       (emit-make-compiled-closure-for-flet/labels 
+			local-function compiland g))))
+	       (delete-file pathname)))))))
 
 (defknown p2-labels-process-compiland (t) t)
 (defun p2-labels-process-compiland (local-function)
@@ -4824,20 +4816,8 @@
                  (error "Unable to load ~S." pathname)))
              (setf (local-function-class-file local-function) class-file)
              (let ((g (declare-local-function local-function)))
-               (emit 'getstatic *this-class* g +lisp-object+)
-
-               (let ((parent (compiland-parent compiland)))
-                 (when (compiland-closure-register parent)
-                   (dformat t "(compiland-closure-register parent) = ~S~%"
-                            (compiland-closure-register parent))
-                   (emit 'checkcast +lisp-ctf-class+)
-                   (aload (compiland-closure-register parent))
-                   (emit-invokestatic +lisp-class+ "makeCompiledClosure"
-                                      (list +lisp-object+ +lisp-object-array+)
-                                      +lisp-object+)))
-
-
-               (emit 'var-set (local-function-variable local-function)))))
+	       (emit-make-compiled-closure-for-flet/labels 
+		local-function compiland g))))
           (t
            (let* ((pathname (make-temp-file))
                   (class-file (make-class-file :pathname pathname
@@ -4847,19 +4827,8 @@
 		   (set-compiland-and-write-class-file class-file compiland)
                    (setf (local-function-class-file local-function) class-file)
                    (let ((g (declare-object (load-compiled-function pathname))))
-                     (emit 'getstatic *this-class* g +lisp-object+)
-
-                     (let ((parent (compiland-parent compiland)))
-                       (when (compiland-closure-register parent)
-                         (dformat t "(compiland-closure-register parent) = ~S~%"
-                                  (compiland-closure-register parent))
-                         (emit 'checkcast +lisp-ctf-class+)
-                         (aload (compiland-closure-register parent))
-                         (emit-invokestatic +lisp-class+ "makeCompiledClosure"
-                                            (list +lisp-object+ +lisp-object-array+)
-                                            +lisp-object+)))
-
-                     (emit 'var-set (local-function-variable local-function))))
+		     (emit-make-compiled-closure-for-flet/labels 
+		      local-function compiland g)))
                (delete-file pathname)))))))
 
 (defknown p2-flet (t t t) t)



From vvoutilainen at common-lisp.net  Fri Jan  2 17:04:20 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Fri, 02 Jan 2009 17:04:20 +0000
Subject: [armedbear-cvs] r11523 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LInRc-0002kc-Cr@common-lisp.net>

Author: vvoutilainen
Date: Fri Jan  2 17:04:19 2009
New Revision: 11523

Log:
Macro for temp files in p2-flet/labels-process-compiland.
At the same time, make the helper function parameter's
name sane.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Jan  2 17:04:19 2009
@@ -4752,8 +4752,9 @@
   (compile-and-write-to-file class-file compiland))
 
 
-(defun emit-make-compiled-closure-for-flet/labels (local-function compiland g)
-  (emit 'getstatic *this-class* g +lisp-object+)
+(defun emit-make-compiled-closure-for-flet/labels 
+    (local-function compiland declaration)
+  (emit 'getstatic *this-class* declaration +lisp-object+)
   (let ((parent (compiland-parent compiland)))
     (when (compiland-closure-register parent)
       (dformat t "(compiland-closure-register parent) = ~S~%"
@@ -4765,6 +4766,14 @@
 			 +lisp-object+)))
   (emit 'var-set (local-function-variable local-function)))
 
+(defmacro with-temp-class-file (pathname class-file lambda-list &body body)
+  `(let* ((,pathname (make-temp-file))
+	  (,class-file (make-class-file :pathname ,pathname
+				       :lambda-list ,lambda-list)))
+     (unwind-protect
+	  (progn , at body)
+       (delete-file pathname))))
+
 
 (defknown p2-flet-process-compiland (t) t)
 (defun p2-flet-process-compiland (local-function)
@@ -4786,20 +4795,15 @@
 	       (emit-make-compiled-closure-for-flet/labels 
 		local-function compiland g))))
           (t
-           (let* ((pathname (make-temp-file))
-                  (class-file (make-class-file :pathname pathname
-                                               :lambda-list lambda-list)))
-             (unwind-protect
-                 (progn
-		   (set-compiland-and-write-class-file class-file compiland)
-                   (setf (local-function-class-file local-function) class-file)
-                   (setf (local-function-function local-function) (load-compiled-function pathname))
-
-                   (when (local-function-variable local-function)
-                     (let ((g (declare-object (load-compiled-function pathname))))
-		       (emit-make-compiled-closure-for-flet/labels 
-			local-function compiland g))))
-	       (delete-file pathname)))))))
+	   (with-temp-class-file 
+	       pathname class-file lambda-list
+	       (set-compiland-and-write-class-file class-file compiland)
+	       (setf (local-function-class-file local-function) class-file)
+	       (setf (local-function-function local-function) (load-compiled-function pathname))
+	       (when (local-function-variable local-function)
+		 (let ((g (declare-object (load-compiled-function pathname))))
+		   (emit-make-compiled-closure-for-flet/labels 
+		    local-function compiland g))))))))
 
 (defknown p2-labels-process-compiland (t) t)
 (defun p2-labels-process-compiland (local-function)
@@ -4819,17 +4823,13 @@
 	       (emit-make-compiled-closure-for-flet/labels 
 		local-function compiland g))))
           (t
-           (let* ((pathname (make-temp-file))
-                  (class-file (make-class-file :pathname pathname
-                                               :lambda-list lambda-list)))
-             (unwind-protect
-                 (progn
-		   (set-compiland-and-write-class-file class-file compiland)
-                   (setf (local-function-class-file local-function) class-file)
-                   (let ((g (declare-object (load-compiled-function pathname))))
-		     (emit-make-compiled-closure-for-flet/labels 
-		      local-function compiland g)))
-               (delete-file pathname)))))))
+	   (with-temp-class-file
+	       pathname class-file lambda-list
+	       (set-compiland-and-write-class-file class-file compiland)
+	       (setf (local-function-class-file local-function) class-file)
+	       (let ((g (declare-object (load-compiled-function pathname))))
+		 (emit-make-compiled-closure-for-flet/labels 
+		  local-function compiland g)))))))
 
 (defknown p2-flet (t t t) t)
 (defun p2-flet (form target representation)



From vvoutilainen at common-lisp.net  Fri Jan  2 17:28:10 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Fri, 02 Jan 2009 17:28:10 +0000
Subject: [armedbear-cvs] r11524 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LInog-0003ni-HY@common-lisp.net>

Author: vvoutilainen
Date: Fri Jan  2 17:28:10 2009
New Revision: 11524

Log:
Tiny helper for checking that class file is loadable.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Jan  2 17:28:10 2009
@@ -4774,7 +4774,11 @@
 	  (progn , at body)
        (delete-file pathname))))
 
-
+(defun verify-class-file-loadable (pathname)
+  (let ((*load-truename* (pathname pathname)))
+    (unless (ignore-errors (load-compiled-function pathname))
+      (error "Unable to load ~S." pathname))))
+  
 (defknown p2-flet-process-compiland (t) t)
 (defun p2-flet-process-compiland (local-function)
   (let* ((compiland (local-function-compiland local-function))
@@ -4784,12 +4788,8 @@
                   (class-file (make-class-file :pathname pathname
                                                :lambda-list lambda-list)))
 	     (set-compiland-and-write-class-file class-file compiland)
-             ;; Verify that the class file is loadable.
-             (let ((*load-truename* (pathname pathname)))
-               (unless (ignore-errors (load-compiled-function pathname))
-                 (error "Unable to load ~S." pathname)))
+	     (verify-class-file-loadable pathname)
              (setf (local-function-class-file local-function) class-file))
-
            (when (local-function-variable local-function)
              (let ((g (declare-local-function local-function)))
 	       (emit-make-compiled-closure-for-flet/labels 
@@ -4814,10 +4814,7 @@
                   (class-file (make-class-file :pathname pathname
                                                :lambda-list lambda-list)))
 	     (set-compiland-and-write-class-file class-file compiland)
-             ;; Verify that the class file is loadable.
-             (let ((*load-truename* (pathname pathname)))
-               (unless (ignore-errors (load-compiled-function pathname))
-                 (error "Unable to load ~S." pathname)))
+	     (verify-class-file-loadable pathname)
              (setf (local-function-class-file local-function) class-file)
              (let ((g (declare-local-function local-function)))
 	       (emit-make-compiled-closure-for-flet/labels 



From vvoutilainen at common-lisp.net  Fri Jan  2 19:50:33 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Fri, 02 Jan 2009 19:50:33 +0000
Subject: [armedbear-cvs] r11525 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LIq2T-0001ld-K4@common-lisp.net>

Author: vvoutilainen
Date: Fri Jan  2 19:50:32 2009
New Revision: 11525

Log:
Helper function for fixnum initializations.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Jan  2 19:50:32 2009
@@ -4991,6 +4991,14 @@
           (t
            (compiler-unsupported "p2-function: unsupported case: ~S" form)))))
 
+(defun emit-fixnum-init (representation)
+  (case representation
+    (:int)
+    (:long
+     (emit 'i2l))
+    (t
+     (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
+
 (defknown p2-ash (t t t) t)
 (defun p2-ash (form target representation)
   (unless (check-arg-count form 2)
@@ -5034,12 +5042,7 @@
                   (emit 'ishr))
                  ((zerop constant-shift)
                   (compile-form arg2 nil nil))) ; for effect
-           (case representation
-             (:int)
-             (:long
-              (emit 'i2l))
-             (t
-              (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+	   (emit-fixnum-init representation)
            (emit-move-from-stack target representation))
           ((and constant-shift
                 ;; lshl/lshr only use the low six bits of the mask.
@@ -5072,12 +5075,7 @@
 						      arg2 'stack :int)
            (emit 'ineg)
            (emit 'ishr)
-           (case representation
-             (:int)
-             (:long
-              (emit 'i2l))
-             (t
-              (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+	   (emit-fixnum-init representation)
            (emit-move-from-stack target representation))
           ((fixnum-type-p type2)
            (cond ((and low2 high2 (<= 0 low2 high2 63) ; Non-negative shift.
@@ -5148,12 +5146,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'iand)
-                (case representation
-                  (:int)
-                  (:long
-                   (emit 'i2l))
-                  (t
-                   (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+		(emit-fixnum-init representation)
                 (emit-move-from-stack target representation))
                ((or (and (fixnum-type-p type1)
                          (compiler-subtypep type1 'unsigned-byte))
@@ -5166,12 +5159,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'iand)
-                (case representation
-                  (:int)
-                  (:long
-                   (emit 'i2l))
-                  (t
-                   (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+		(emit-fixnum-init representation)
                 (emit-move-from-stack target representation))
                ((and (java-long-type-p type1) (java-long-type-p type2))
                 ;; Both arguments are longs.
@@ -5263,12 +5251,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'ior)
-                (case representation
-                  (:int)
-                  (:long
-                   (emit 'i2l))
-                  (t
-                   (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+		(emit-fixnum-init representation)
                 (emit-move-from-stack target representation))
                ((and (eql (fixnum-constant-value type1) 0) (< *safety* 3))
 		(compile-forms-and-maybe-emit-clear-values arg1 nil nil
@@ -5345,12 +5328,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'ixor)
-                (case representation
-                  (:int)
-                  (:long
-                   (emit 'i2l))
-                  (t
-                   (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
+		(emit-fixnum-init representation))
                ((and (java-long-type-p type1) (java-long-type-p type2))
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							   arg2 'stack :long)
@@ -5386,12 +5364,7 @@
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
            (emit 'iconst_m1)
            (emit 'ixor)
-           (case representation
-             (:int)
-             (:long
-              (emit 'i2l))
-             (t
-              (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+	   (emit-fixnum-init representation)
            (emit-move-from-stack target representation)))
         (t
          (let ((arg (%cadr form)))
@@ -5436,12 +5409,7 @@
                     (emit 'ishr))
                   (emit-push-constant-int (1- (expt 2 size))) ; mask
                   (emit 'iand)
-                  (case representation
-                    (:int)
-                    (:long
-                     (emit 'i2l))
-                    (t
-                     (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+		  (emit-fixnum-init representation)
                   (emit-move-from-stack target representation))
                  ((<= (+ position size) 63)
                   (when (and (null representation) (<= size 31))
@@ -5458,12 +5426,7 @@
                          (emit 'l2i)
                          (emit-push-constant-int (1- (expt 2 size)))
                          (emit 'iand)
-                         (case representation
-                           (:int)
-                           (:long
-                            (emit 'i2l))
-                           (t
-                            (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
+			 (emit-fixnum-init representation))
                         (t
                          (emit-push-constant-long (1- (expt 2 size))) ; mask
                          (emit 'land)
@@ -6625,12 +6588,7 @@
                         (label LABEL1)
                         (emit 'iload reg2)
                         (label LABEL2)))
-                    (case representation
-                      (:int)
-                      (:long
-                       (emit 'i2l))
-                      (t
-                       (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+		    (emit-fixnum-init representation)
                     (emit-move-from-stack target representation))
                    ((and (java-long-type-p type1) (java-long-type-p type2))
                     (let* ((*register* *register*)
@@ -6716,12 +6674,7 @@
 		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 								arg2 'stack :int)
                      (emit 'iadd)
-                     (case representation
-                       (:int)
-                       (:long
-                        (emit 'i2l))
-                       (t
-                        (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
+		     (emit-fixnum-init representation))
                     (t
                      (compile-form arg1 'stack :int)
                      (emit 'i2l)
@@ -6799,12 +6752,7 @@
                 (emit 'dup))
               (compile-form arg 'stack :int)
               (emit 'ineg)
-              (case representation
-                (:int)
-                (:long
-                 (emit 'i2l))
-                (t
-                 (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+	      (emit-fixnum-init representation)
               (emit-move-from-stack target representation))
              ((and (java-long-type-p type)
                    (integer-type-low type)
@@ -6842,12 +6790,7 @@
 		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 								arg2 'stack :int)
                      (emit 'isub)
-                     (case representation
-                       (:int)
-                       (:long
-                        (emit 'i2l))
-                       (t
-                        (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
+		     (emit-fixnum-init representation))
                     (t
                      (compile-form arg1 'stack :int)
                      (emit 'i2l)
@@ -7147,12 +7090,7 @@
                       (emit 'new +lisp-fixnum-class+)
                       (emit 'dup))
                     (emit 'iload value-register)
-                    (case representation
-                      (:int)
-                      (:long
-                       (emit 'i2l))
-                      (t
-                       (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
+		    (emit-fixnum-init representation))
                    (t
                     (aload value-register)
                     (fix-boxing representation type3)))
@@ -7899,12 +7837,7 @@
              (emit 'new +lisp-fixnum-class+)
              (emit 'dup))
            (compile-form arg 'stack :char)
-           (case representation
-             (:int)
-             (:long
-              (emit 'i2l))
-             (t
-              (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+	   (emit-fixnum-init representation)
            (emit-move-from-stack target representation))
           (t
            (compile-function-call form target representation)))))



From ehuelsmann at common-lisp.net  Sat Jan  3 00:08:31 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 03 Jan 2009 00:08:31 +0000
Subject: [armedbear-cvs] r11526 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LIu47-0005y3-NB@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan  3 00:08:31 2009
New Revision: 11526

Log:
Make Throw.java do as Lisp.java and LispThread.java: create a human-readable tag for the 
error message.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Throw.java

Modified: trunk/abcl/src/org/armedbear/lisp/Throw.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Throw.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Throw.java	Sat Jan  3 00:08:31 2009
@@ -58,7 +58,7 @@
     {
         try {
             return new ControlError("Attempt to throw to the nonexistent tag " +
-                                    tag + ".");
+                                    tag.writeToString() + ".");
         }
         catch (Throwable t) {
             Debug.trace(t);



From mevenson at common-lisp.net  Sat Jan  3 12:30:17 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sat, 03 Jan 2009 12:30:17 +0000
Subject: [armedbear-cvs] r11527 - in trunk/abcl: . src/org/armedbear/lisp
	test test/src test/src/org test/src/org/armedbear
	test/src/org/armedbear/lisp
Message-ID: <E1LJ5dx-0007kR-0B@common-lisp.net>

Author: mevenson
Date: Sat Jan  3 12:30:16 2009
New Revision: 11527

Log:
(Phil Hudson) Make FastStringBuffer an adapter to java-1.5's StringBuilder.

JUnit tests integrated into 'build.xml', run via 'ant abcl.test'.

Further integration with other build systems (Lisp and Netbeans) has not been done.



Added:
   trunk/abcl/test/
   trunk/abcl/test/src/
   trunk/abcl/test/src/org/
   trunk/abcl/test/src/org/armedbear/
   trunk/abcl/test/src/org/armedbear/lisp/
   trunk/abcl/test/src/org/armedbear/lisp/FastStringBufferTest.java
Modified:
   trunk/abcl/build.xml
   trunk/abcl/src/org/armedbear/lisp/FastStringBuffer.java

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Sat Jan  3 12:30:16 2009
@@ -17,19 +17,24 @@
 	      value="${basedir}/dist"/>
     <property name="abcl.jar.path"
 	      value="${dist.dir}/abcl.jar"/>
+    <property name="abcl.ext.dir"
+	      value="${basedir}/ext"/>
+
 
     <target name="help">
       <echo>Main Ant targets:
  abcl.compile  
-   -- compile ABCL to ${build.classes.dir}
+   -- compile ABCL to ${build.classes.dir}.
  abcl.jar      
-   -- create packaged ${abcl.jar.path}
+   -- create packaged ${abcl.jar.path}.
  abcl.wrapper  
-   -- create executable wrapper for ABCL
+   -- create executable wrapper for ABCL.
  abcl.source.zip abcl.source.tar
-    -- create source distributions in ${dist.dir}
+   -- create source distributions in ${dist.dir}.
+ acbl.test.java
+   -- Run junit tests under ${abcl.test.src.dir}.
  abcl.clean 
-    -- remove ABCL intermediate files</echo>
+   -- remove ABCL intermediate files</echo>
       <echo>Corresponding targets for J have been removed.</echo>
     </target>
 
@@ -393,6 +398,56 @@
       </zip>
     </target>
 
+    <property name="abcl.test.classes.dir"
+	      value="${build.dir}/classes-test"/>
+
+    <property name="abcl.test.src.dir"
+	      value="${basedir}/test/src"/>
+
+    <patternset id="abcl.test.source.java">
+      <!-- For now, we list tests explicitly, because we have to
+           enumerate them later to the JUnit test runner. -->
+      <include name="org/armedbear/lisp/FastStringBufferTest.java"/>
+    </patternset>
+
+    <property name="junit-4.5.path"
+	      value="${abcl.ext.dir}/junit-4.5.jar"/>
+
+    <path id="abcl.test.compile.classpath">
+      <pathelement location="${junit-4.5.path}"/>
+      <pathelement location="${build.classes.dir}"/>
+    </path>
+
+    <target name="abcl.test.pre-compile">
+      <mkdir dir="${abcl.ext.dir}"/>
+      <get src="http://downloads.sourceforge.net/junit/junit-4.5.jar?modtime=1218209625"
+	  dest="${junit-4.5.path}"/>
+    </target>
+	
+    <target name="abcl.test.compile" depends="abcl.test.pre-compile,abcl.compile">
+      <mkdir dir="${abcl.test.classes.dir}"/>
+      <javac destdir="${abcl.test.classes.dir}"
+	     classpathref="abcl.test.compile.classpath"
+	     debug="true"
+	     target="1.5">
+	<src path="${abcl.test.src.dir}"/>
+	<patternset refid="abcl.test.source.java"/>
+      </javac>
+    </target>
+
+    <path id="abcl.test.run.classpath">
+      <path refid="abcl.test.compile.classpath"/>
+      <pathelement location="${abcl.test.classes.dir}"/>
+    </path>
+	
+    <target name="abcl.test.java" depends="abcl.test.compile">
+      <java fork="true"
+	    classpathref="abcl.test.run.classpath"
+	    classname="org.junit.runner.JUnitCore">
+	<arg value="org.armedbear.lisp.FastStringBufferTest"/>
+      </java>
+    </target>
+
     <import file="netbeans-build.xml" optional="true"/> 
 <!--    <import file="j-build.xml" optional="true"/>  -->
     <import file="not.org-build.xml" optional="true"/> 

Modified: trunk/abcl/src/org/armedbear/lisp/FastStringBuffer.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FastStringBuffer.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/FastStringBuffer.java	Sat Jan  3 12:30:16 2009
@@ -2,6 +2,7 @@
  * FastStringBuffer.java
  *
  * Copyright (C) 1998-2005 Peter Graves
+ * Copyright (C) 2008 Phil Hudson
  * $Id$
  *
  * This program is free software; you can redistribute it and/or
@@ -33,128 +34,84 @@
 
 package org.armedbear.lisp;
 
-public final class FastStringBuffer
+/** 
+ * An adaptor of the Java 1.5 java.lang.StringBuilder.
+ * 
+ * "This class should be removed with all references to it replaced
+ *  with java.lang.StringBuilder once enough confidence in this change
+ *  has been gained." -- Phil Hudson 20090202 via <armedbear-j-devel>.
+ */
+public final class FastStringBuffer implements Appendable, CharSequence
 {
   private static final int SPARE_CAPACITY = 128;
 
-  private char[] buffer;
-  private int used;
+  private final StringBuilder builder;
 
   public FastStringBuffer()
   {
-    buffer = new char[SPARE_CAPACITY];
+    this(SPARE_CAPACITY);
   }
 
-  public FastStringBuffer(String s)
+  public FastStringBuffer(String s) 
   {
-    used = s.length();
-    buffer = new char[used + SPARE_CAPACITY];
-    s.getChars(0, used, buffer, 0);
+    builder = new StringBuilder(s);
   }
 
   public FastStringBuffer(char c)
   {
-    used = 1;
-    buffer = new char[1 + SPARE_CAPACITY];
-    buffer[0] = c;
+    this(String.valueOf(c));
   }
 
   public FastStringBuffer(int length) throws NegativeArraySizeException
   {
-    if (length < 0)
-      throw new NegativeArraySizeException();
-    buffer = new char[length];
+    builder = new StringBuilder(length);
   }
 
   public final int length()
   {
-    return used;
+    return builder.length();
   }
 
   public final int capacity()
   {
-    return buffer.length;
+    return builder.capacity();
   }
 
   public final char charAt(int index)
   {
-    try
-      {
-        return buffer[index];
-      }
-    catch (ArrayIndexOutOfBoundsException e)
-      {
-        throw new StringIndexOutOfBoundsException();
-      }
+    return builder.charAt(index);
   }
 
   public void getChars(int srcBegin, int srcEnd, char dst[], int dstBegin)
   {
-    if (srcBegin < 0 || srcBegin > srcEnd || srcEnd > used)
-      throw new StringIndexOutOfBoundsException();
-    System.arraycopy(buffer, srcBegin, dst, dstBegin, srcEnd - srcBegin);
+    builder.getChars(srcBegin, srcEnd, dst, dstBegin);
   }
 
   public void setCharAt(int index, char c)
   {
-    try
-      {
-        buffer[index] = c;
-      }
-    catch (ArrayIndexOutOfBoundsException e)
-      {
-        throw new StringIndexOutOfBoundsException();
-      }
+    builder.setCharAt(index, c);
   }
 
   public void ensureCapacity(int minimumCapacity)
   {
-    if (buffer.length < minimumCapacity)
-      {
-        int newCapacity = buffer.length * 2 + 2;
-        if (newCapacity < minimumCapacity)
-          newCapacity = minimumCapacity;
-        char newBuffer[] = new char[newCapacity];
-        System.arraycopy(buffer, 0, newBuffer, 0, used);
-        buffer = newBuffer;
-      }
-  }
-
-  public void setText(String s)
-  {
-    used = 0;
-    append(s);
+    builder.ensureCapacity(minimumCapacity);
   }
 
   public FastStringBuffer append(String s)
   {
-    if (s == null)
-      s = "null";
-    int addedLength = s.length();
-    int combinedLength = used + addedLength;
-    ensureCapacity(combinedLength);
-    s.getChars(0, addedLength, buffer, used);
-    used = combinedLength;
+    builder.append(s);
     return this;
   }
 
   public FastStringBuffer append(char[] chars)
   {
-    if (used + chars.length > buffer.length)
-      ensureCapacity(used + chars.length);
-    System.arraycopy(chars, 0, buffer, used, chars.length);
-    used += chars.length;
+    builder.append(chars);
     return this;
   }
 
   public FastStringBuffer append(char[] chars, int offset, int len)
   {
-    if (offset < 0 || len < 0 || offset + len > chars.length)
-      throw new StringIndexOutOfBoundsException();
-    if (used + len > buffer.length)
-      ensureCapacity(used + len);
-    System.arraycopy(chars, offset, buffer, used, len);
-    used += len;
+    builder.append(chars, offset, len);
     return this;
   }
 
@@ -165,9 +122,7 @@
 
   public FastStringBuffer append(char c)
   {
-    if (used + 1 > buffer.length)
-      ensureCapacity(used + 1);
-    buffer[used++] = c;
+    builder.append(c);
     return this;
   }
 
@@ -183,34 +138,40 @@
 
   public void setLength(int newLength) throws IndexOutOfBoundsException
   {
-    if (newLength < 0)
-      throw new StringIndexOutOfBoundsException(newLength);
-    ensureCapacity(newLength);
-    used = newLength;
+    builder.setLength(newLength);
   }
 
   public FastStringBuffer reverse()
   {
-    final int limit = used / 2;
-    for (int i = 0; i < limit; ++i)
-      {
-        char c = buffer[i];
-        buffer[i] = buffer[used - i - 1];
-        buffer[used - i - 1] = c;
-      }
-    return this;
+    builder.reverse();
+    return this; 
   }
 
   @Override
   public final String toString()
   {
-    return new String(buffer, 0, used);
+    return builder.toString();
   }
 
   public final char[] toCharArray()
   {
-    char[] copy = new char[used];
-    System.arraycopy(buffer, 0, copy, 0, used);
-    return copy;
+    return toString().toCharArray();
   }
+
+   public CharSequence subSequence(int start, int end)
+  {
+    return builder.subSequence(start, end);
+   }
+ 
+   public FastStringBuffer append(CharSequence seq)
+   {
+     builder.append(seq);
+     return this;
+   }
+ 
+   public FastStringBuffer append(CharSequence seq, int start, int end)
+   {
+     builder.append(seq, start, end);
+     return this;
+   }
 }

Added: trunk/abcl/test/src/org/armedbear/lisp/FastStringBufferTest.java
==============================================================================
--- (empty file)
+++ trunk/abcl/test/src/org/armedbear/lisp/FastStringBufferTest.java	Sat Jan  3 12:30:16 2009
@@ -0,0 +1,289 @@
+package org.armedbear.lisp;
+
+import static java.lang.Math.abs;
+import java.util.Random;
+
+import org.junit.After;
+import static org.junit.Assert.*;
+import org.junit.Before;
+import org.junit.Test;
+import org.junit.runner.JUnitCore;
+import org.junit.Assert;
+import java.util.Date;
+
+/**
+ * Unit tests for {@link FastStringBuffer}.
+ */
+public class FastStringBufferTest
+{
+    /** Class under test. */
+    private static final Class CLASS = FastStringBuffer.class;
+    private static final Random random = new Random();
+    private static final String CTOR_ARG = "abcde";
+
+    public static void main(final String args[]) {
+        JUnitCore.main("org.armedbear.lisp.FastStringBufferTest");
+    }
+
+    /** Test instance. */
+    private FastStringBuffer buffer = null;
+
+    @Before
+    public void setUp()
+    {
+        buffer = new FastStringBuffer(CTOR_ARG);
+    }
+
+    @After
+    public void tearDown()
+    {
+        buffer = null;
+    }
+
+    @Test
+    public void defaultConstructor()
+    {
+        assertNotNull("Default constructor failed", new FastStringBuffer());
+    }
+
+    @Test
+    public void constructorString()
+    {
+        assertNotNull("String constructor failed",
+                      new FastStringBuffer(CTOR_ARG));
+    }
+
+    @Test
+    public void constructorchar()
+    {
+        assertNotNull("char constructor failed", new FastStringBuffer('c'));
+    }
+
+    @Test
+    public void constructorint()
+    {
+        assertNotNull("int constructor failed", new FastStringBuffer(12));
+    }
+
+    @Test(expected=OutOfMemoryError.class)
+    public void constructorMaxint()
+    {
+        new FastStringBuffer(Integer.MAX_VALUE);
+    }
+
+    @Test(expected=NegativeArraySizeException.class)
+    public void constructorMinint()
+    {
+        new FastStringBuffer(Integer.MIN_VALUE);
+    }
+
+    @Test
+    public void lengthAfterConstructorint()
+    {
+        final FastStringBuffer foo = new FastStringBuffer(234);
+        assertEquals("Length from int constructor not 0", 0, foo.length());
+    }
+
+    @Test
+    public void lengthAfterDefaultConstructor()
+    {
+        assertEquals("Length from default constructor not 0", 0,
+                     new FastStringBuffer().length());
+    }
+
+    @Test
+    public void lengthAfterConstructorString()
+    {
+        final int len = CTOR_ARG.length();
+        assertEquals("Length from String constructor not " + len, len,
+                     new FastStringBuffer(CTOR_ARG).length());
+    }
+
+    @Test
+    public void lengthAfterConstructorchar()
+    {
+        final char w = 'w';
+        final FastStringBuffer newBuffer = new FastStringBuffer(w);
+        final int len = newBuffer.length();
+        assertEquals("Length from char constructor: " + len, 1, len);
+    }
+
+    // Target method to be made private during refactoring
+    // @Test(expect=NoSuchMethodException.class)
+    @Test
+    public void capacity() throws NoSuchMethodException
+    {
+        CLASS.getMethod("capacity", (Class[]) null);
+    }
+
+    @Test
+    public void charAt()
+    {
+        assertEquals("Indexed char unexpected", 'c', buffer.charAt(2));
+    }
+
+    @Test
+    public void getChars()
+    {
+        final char[] dst = {0, 0};
+        final char[] cmp = {'b', 'c'};
+        buffer.getChars(1, 3, dst, 0);
+        assertArrayEquals("Subarray unexpected; cmp: " + new String(cmp) +
+                          ", dst: " + new String(dst), cmp, dst);
+    }
+
+    @Test(expected=StringIndexOutOfBoundsException.class)
+    public void getCharsBadStartIndex()
+    {
+        buffer.getChars(-1, -1, null, 0);
+    }
+
+    @Test(expected=StringIndexOutOfBoundsException.class)
+    public void getCharsInvertedStartEnd()
+    {
+        buffer.getChars(3, 1, null, 0);
+    }
+
+    @Test(expected=StringIndexOutOfBoundsException.class)
+    public void getCharsExcessiveEnd()
+    {
+        buffer.getChars(1, 7, null, 0);
+    }
+
+    @Test
+    public void setCharAt()
+    {
+        buffer.setCharAt(2, 'z');
+        assertEquals("Incorrect setCharAt", "abzde", buffer.toString());
+    }
+
+    @Test(expected=IndexOutOfBoundsException.class)
+    public void setCharAtExcess()
+    {
+        buffer.setCharAt(8, 'x');
+    }
+
+    @Test(expected=StringIndexOutOfBoundsException.class)
+    public void setCharAtNeg()
+    {
+        buffer.setCharAt(-2, 'x');
+    }
+
+    @Test
+    public void ensureCapacity()
+    {
+        buffer.ensureCapacity(200);
+        assertTrue("Unexpected capacity", buffer.capacity() >= 200);
+    }
+
+    @Test(expected=NoSuchMethodException.class)
+    public void setText() throws NoSuchMethodException
+    {
+        FastStringBuffer.class.getMethod("setText");
+    }
+
+    @Test
+    public void append()
+    {
+        buffer.append("fgh");
+        assertEquals("abcdefgh", buffer.toString());
+    }
+
+    @Test
+    public void appendNullString()
+    {
+        buffer.append((String)null);
+        assertEquals("abcdenull", buffer.toString());
+    }
+
+    @Test
+    public void appendcharArray()
+    {
+        buffer.append(new char[]{'x', 'y', 'z'});
+        assertEquals("abcdexyz", buffer.toString());
+    }
+
+    @Test(expected=NullPointerException.class)
+    public void appendNullcharArray()
+    {
+        buffer.append((char []) null);
+    }
+
+    @Test(expected=IndexOutOfBoundsException.class)
+    public void appendWithin()
+    {
+        buffer.append(new char[]{'x', 'y', 'z'}, 1, 3);
+        assertEquals("abcdexyz", buffer.toString());
+    }
+
+    @Test
+    public void appendObject()
+    {
+        buffer.append(new Date());
+        assertTrue(buffer.length() > 5);
+    }
+
+    @Test
+    public void appendchar()
+    {
+        buffer.append('f');
+        assertEquals("abcdef", buffer.toString());
+    }
+
+    @Test
+    public void appendint()
+    {
+        buffer.append(1);
+        assertEquals("abcde1", buffer.toString());
+    }
+
+    @Test
+    public void appendlong()
+    {
+        buffer.append(1L);
+        assertEquals("abcde1", buffer.toString());
+    }
+
+    @Test
+    public void setLength()
+    {
+        buffer.setLength(3);
+        assertEquals("abc", buffer.toString());
+    }
+
+    @Test(expected=IndexOutOfBoundsException.class)
+    public void setLengthNeg()
+    {
+        buffer.setLength(-1);
+    }
+
+    @Test
+    public void setLengthExcess()
+    {
+        buffer.setLength(12);
+        assertEquals(12, buffer.length());
+        // This just seems weird to me
+        assertFalse(CTOR_ARG.equals(buffer.toString()));
+    }
+
+    @Test
+    public void reverse()
+    {
+        buffer.reverse();
+        assertEquals("edcba", buffer.toString());
+    }
+
+    @Test
+    public void testToString()
+    {
+        assertEquals(CTOR_ARG, buffer.toString());
+    }
+
+    @Test
+    public void toCharArray()
+    {
+        assertArrayEquals(new char[] {'a', 'b', 'c', 'd', 'e'},
+                          buffer.toCharArray());
+    }
+
+}



From mevenson at common-lisp.net  Sat Jan  3 13:08:57 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sat, 03 Jan 2009 13:08:57 +0000
Subject: [armedbear-cvs] r11528 - in trunk/abcl: . nbproject
	src/org/armedbear/lisp
Message-ID: <E1LJ6FN-0001PW-0n@common-lisp.net>

Author: mevenson
Date: Sat Jan  3 13:08:56 2009
New Revision: 11528

Log:
Enable optional use of JFluid profiler.

Modified:
   trunk/abcl/build.properties.in
   trunk/abcl/nbproject/build-impl.xml
   trunk/abcl/nbproject/genfiles.properties
   trunk/abcl/nbproject/project.properties
   trunk/abcl/nbproject/project.xml
   trunk/abcl/netbeans-build.xml
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/Closure.java
   trunk/abcl/src/org/armedbear/lisp/StandardClass.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java
   trunk/abcl/src/org/armedbear/lisp/Version.java
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/java.lisp
   trunk/abcl/src/org/armedbear/lisp/print-object.lisp

Modified: trunk/abcl/build.properties.in
==============================================================================
--- trunk/abcl/build.properties.in	(original)
+++ trunk/abcl/build.properties.in	Sat Jan  3 13:08:56 2009
@@ -1,2 +1,10 @@
 # build.properties
 # $Id: build.properties,v 1.23 2007-03-03 19:19:11 piso Exp $
+
+#additional.jars=${user.home}/work/lsw/lib/bsh-2.0b4.jar:${user.home}/work/lsw/lib/jscheme.jar
+#java.options=-Xmx2g
+
+#abcl.src.version=r14888+possibly-scripting
+
+
+#abcl.build.module=scripting

Modified: trunk/abcl/nbproject/build-impl.xml
==============================================================================
--- trunk/abcl/nbproject/build-impl.xml	(original)
+++ trunk/abcl/nbproject/build-impl.xml	Sat Jan  3 13:08:56 2009
@@ -64,7 +64,9 @@
             </and>
         </condition>
         <condition property="have.tests">
-            <or/>
+            <or>
+                <available file="${test.src.dir}"/>
+            </or>
         </condition>
         <condition property="have.sources">
             <or>
@@ -123,6 +125,7 @@
     </target>
     <target depends="-pre-init,-init-private,-init-user,-init-project,-do-init" name="-init-check">
         <fail unless="src.dir">Must set src.dir</fail>
+        <fail unless="test.src.dir">Must set test.src.dir</fail>
         <fail unless="build.dir">Must set build.dir</fail>
         <fail unless="dist.dir">Must set dist.dir</fail>
         <fail unless="build.classes.dir">Must set build.classes.dir</fail>
@@ -196,7 +199,11 @@
             <attribute default="**" name="testincludes"/>
             <sequential>
                 <junit dir="${work.dir}" errorproperty="tests.failed" failureproperty="tests.failed" fork="true" showoutput="true">
-                    <batchtest todir="${build.test.results.dir}"/>
+                    <batchtest todir="${build.test.results.dir}">
+                        <fileset dir="${test.src.dir}" excludes="@{excludes},${excludes}" includes="@{includes}">
+                            <filename name="@{testincludes}"/>
+                        </fileset>
+                    </batchtest>
                     <classpath>
                         <path path="${run.test.classpath}"/>
                     </classpath>
@@ -501,11 +508,13 @@
         <!-- You can override this target in the ../build.xml file. -->
     </target>
     <target if="do.depend.true" name="-compile-test-depend">
-        <j2seproject3:depend classpath="${javac.test.classpath}" destdir="${build.test.classes.dir}" srcdir=""/>
+        <j2seproject3:depend classpath="${javac.test.classpath}" destdir="${build.test.classes.dir}" srcdir="${test.src.dir}"/>
     </target>
     <target depends="init,compile,-pre-pre-compile-test,-pre-compile-test,-compile-test-depend" if="have.tests" name="-do-compile-test">
-        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" srcdir=""/>
-        <copy todir="${build.test.classes.dir}"/>
+        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" srcdir="${test.src.dir}"/>
+        <copy todir="${build.test.classes.dir}">
+            <fileset dir="${test.src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
+        </copy>
     </target>
     <target name="-post-compile-test">
         <!-- Empty placeholder for easier customization. -->
@@ -519,8 +528,10 @@
     <target depends="init,compile,-pre-pre-compile-test,-pre-compile-test-single" if="have.tests" name="-do-compile-test-single">
         <fail unless="javac.includes">Must select some files in the IDE or set javac.includes</fail>
         <j2seproject3:force-recompile destdir="${build.test.classes.dir}"/>
-        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" excludes="" includes="${javac.includes}" sourcepath="" srcdir=""/>
-        <copy todir="${build.test.classes.dir}"/>
+        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" excludes="" includes="${javac.includes}" sourcepath="${test.src.dir}" srcdir="${test.src.dir}"/>
+        <copy todir="${build.test.classes.dir}">
+            <fileset dir="${test.src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
+        </copy>
     </target>
     <target name="-post-compile-test-single">
         <!-- Empty placeholder for easier customization. -->

Modified: trunk/abcl/nbproject/genfiles.properties
==============================================================================
--- trunk/abcl/nbproject/genfiles.properties	(original)
+++ trunk/abcl/nbproject/genfiles.properties	Sat Jan  3 13:08:56 2009
@@ -3,8 +3,8 @@
 build.xml.stylesheet.CRC32=be360661
 # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml.
 # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you.
-nbproject/build-impl.xml.data.CRC32=71623fcd
-nbproject/build-impl.xml.script.CRC32=7d8238bd
+nbproject/build-impl.xml.data.CRC32=742204ce
+nbproject/build-impl.xml.script.CRC32=b94c76f8
 nbproject/build-impl.xml.stylesheet.CRC32=e55b27f5
 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd
 nbproject/profiler-build-impl.xml.script.CRC32=abda56ed

Modified: trunk/abcl/nbproject/project.properties
==============================================================================
--- trunk/abcl/nbproject/project.properties	(original)
+++ trunk/abcl/nbproject/project.properties	Sat Jan  3 13:08:56 2009
@@ -17,10 +17,11 @@
 dist.dir=dist
 dist.jar=${dist.dir}/abcl.jar
 dist.javadoc.dir=${dist.dir}/javadoc
-excludes=
+excludes=org/armedbear/lisp/scripting/*.java
 file.reference.abcl-src=src
 includes=org/armedbear/lisp/**/*.java,org/armedbear/lisp/**/*.lisp
 jar.compress=true
+javac.classpath=
 # Space-separated list of extra javac options
 javac.compilerargs=
 javac.deprecation=false
@@ -65,3 +66,4 @@
 src.dir=${file.reference.abcl-src}
 src.doc.dir=doc
 src.themes.dir=themes
+test.src.dir=test/src

Modified: trunk/abcl/nbproject/project.xml
==============================================================================
--- trunk/abcl/nbproject/project.xml	(original)
+++ trunk/abcl/nbproject/project.xml	Sat Jan  3 13:08:56 2009
@@ -8,7 +8,9 @@
             <source-roots>
                 <root id="src.dir"/>
             </source-roots>
-            <test-roots/>
+            <test-roots>
+                <root id="test.src.dir" name="test/src"/>
+            </test-roots>
         </data>
     </configuration>
 </project>

Modified: trunk/abcl/netbeans-build.xml
==============================================================================
--- trunk/abcl/netbeans-build.xml	(original)
+++ trunk/abcl/netbeans-build.xml	Sat Jan  3 13:08:56 2009
@@ -5,6 +5,7 @@
 <!-- XXX need way to autodetect NetBeans as installed, as this will
      probably fail otherwise.  -->
   <import file="nbproject/build-impl.xml"/>
+  <import file="nbproject/profiler-build-impl.xml" optional="true"/>
 
   <target name="-post-compile">
     <echo>build.classes.dir: ${build.classes.dir}</echo>

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Sat Jan  3 13:08:56 2009
@@ -452,6 +452,8 @@
         autoload("print-not-readable-object", "PrintNotReadable");
         autoload("probe-file", "probe_file");
         autoload("rational", "FloatFunctions");
+	autoload("read-char-no-hang", "read_char_no_hang");
+	autoload("read-delimited-list", "read_delimited_list");
         autoload("rem", "rem");
         autoload("remhash", "HashTableFunctions");
         autoload("remhash", "HashTableFunctions");
@@ -513,6 +515,9 @@
         autoload(PACKAGE_EXT, "thread-lock", "ThreadLock", true);
         autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true);
         autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
+	autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass");
+	autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
+	autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");
         autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");
         autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass");
         autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");

Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Closure.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Closure.java	Sat Jan  3 13:08:56 2009
@@ -595,6 +595,8 @@
         final LispThread thread = LispThread.currentThread();
         SpecialBinding lastSpecialBinding = thread.lastSpecialBinding;
         Environment ext = new Environment(environment);
+	for (Symbol special: specials)
+	  ext.declareSpecial(special);
         bindRequiredParameters(ext, thread, first, second, third, fourth,
                                fifth, sixth, seventh);
         return bindParametersAndExecute(ext, thread, 

Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sat Jan  3 13:08:56 2009
@@ -123,6 +123,9 @@
   public static final StandardClass BUILT_IN_CLASS =
     addStandardClass(Symbol.BUILT_IN_CLASS, list1(CLASS));
 
+  public static final StandardClass JAVA_CLASS =
+    addStandardClass(Symbol.JAVA_CLASS, list1(CLASS));
+
   public static final StandardClass FORWARD_REFERENCED_CLASS =
     addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list1(CLASS));
 
@@ -280,6 +283,8 @@
                                list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS")))));
     BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT,
                           BuiltInClass.CLASS_T);
+    JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT,
+                          BuiltInClass.CLASS_T);
     CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
                       STANDARD_OBJECT, BuiltInClass.CLASS_T);
     CELL_ERROR.setDirectSlotDefinitions(

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Sat Jan  3 13:08:56 2009
@@ -2900,6 +2900,8 @@
     PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION-CAUSE");
   public static final Symbol JAVA_OBJECT =
     PACKAGE_JAVA.addExternalSymbol("JAVA-OBJECT");
+  public static final Symbol JAVA_CLASS =
+    PACKAGE_JAVA.addExternalSymbol("JAVA-CLASS");
   public static final Symbol JCALL =
     PACKAGE_JAVA.addExternalSymbol("JCALL");
   public static final Symbol JCALL_RAW =

Modified: trunk/abcl/src/org/armedbear/lisp/Version.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Version.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Version.java	Sat Jan  3 13:08:56 2009
@@ -41,6 +41,6 @@
 
   public static String getVersion()
   {
-    return "0.13.0-dev";
+    return "0.12.25";
   }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Sat Jan  3 13:08:56 2009
@@ -201,6 +201,8 @@
 (autoload 'jinterface-implementation "java")
 (export 'jobject-class "JAVA")
 (autoload 'jobject-class "java")
+(export 'jproperty-value "JAVA")
+(autoload 'jproperty-value "java")
 (export 'jclass-superclass "JAVA")
 (autoload 'jclass-superclass "java")
 (export 'jclass-interfaces "JAVA")

Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp	Sat Jan  3 13:08:56 2009
@@ -75,6 +75,79 @@
         (push method-name method-names-and-defs)))
     (apply #'%jnew-proxy interface method-names-and-defs)))
 
+(defun jmake-invocation-handler (function)
+  (%jmake-invocation-handler function))
+ 
+(when (autoloadp 'jmake-proxy)
+  (fmakunbound 'jmake-proxy))
+ 
+(defgeneric jmake-proxy (interface implementation &optional lisp-this)
+   (:documentation "Returns a proxy Java object implementing the
+   provided interface using methods implemented in Lisp - typically
+   closures, but implementations are free to provide other
+   mechanisms. You can pass an optional 'lisp-this' object that will
+   be passed to the implementing methods as their first argument. If
+   you don't provide this object, NIL will be used. The second
+   argument of the Lisp methods is the name of the Java method being
+   implemented. This has the implication that overloaded methods are
+   merged, so you have to manually discriminate them if you want
+   to. The remaining arguments are java-objects wrapping the method's
+   parameters."))
+
+(defmethod jmake-proxy (interface invocation-handler &optional lisp-this)
+  "Basic implementation that directly uses an invocation handler."
+  (%jmake-proxy (jclass interface) invocation-handler lisp-this))
+
+(defmethod jmake-proxy (interface (implementation function) &optional lisp-this)
+   "Implements a Java interface forwarding method calls to a Lisp function."
+   (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this))
+
+ (defmethod jmake-proxy (interface (implementation package) &optional lisp-this)
+   "Implements a Java interface mapping Java method names to symbols
+in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME
+symbol. An error is signaled if no such symbol exists in the package,
+or if the symbol exists but does not name a function."
+
+   (flet ((java->lisp (name)
+	    (with-output-to-string (str)
+	      (let ((last-lower-p nil))
+		(map nil (lambda (char)
+			   (let ((upper-p (char= (char-upcase char) char)))
+			     (when (and last-lower-p upper-p)
+			       (princ "-" str))
+			     (setf last-lower-p (not upper-p))
+			     (princ (char-upcase char) str)))
+		     name)))))
+     (%jmake-proxy (jclass interface)
+		   (jmake-invocation-handler 
+		    (lambda (obj method &rest args)
+		      (let ((sym (find-symbol
+				  (java->lisp method)
+				  implementation)))
+			(unless sym
+			  (error "Symbol ~A, implementation of method ~A, not found in ~A"
+				 (java->lisp method)
+				 method
+				 implementation))
+			(if (fboundp sym)
+			    (apply (symbol-function sym) obj method args)
+			    (error "Function ~A, implementation of method ~A, not found in ~A"
+				   sym method implementation)))))
+		   lisp-this)))
+
+(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this)
+   "Implements a Java interface using closures in an hash-table keyed
+by Java method name."
+   (%jmake-proxy (jclass interface)
+ 		(jmake-invocation-handler 
+ 		 (lambda (obj method &rest args)
+ 		   (let ((fn (gethash method implementation)))
+ 		     (if fn
+ 			 (apply fn obj args)
+			 (error "Implementation for method ~A not found in ~A"
+ 				method implementation)))))
+ 		lisp-this))
+ 
 (defun jobject-class (obj)
   "Returns the Java class that OBJ belongs to"
   (jcall (jmethod "java.lang.Object" "getClass") obj))
@@ -233,3 +306,9 @@
       (error "Unknown load-from for ~A" class-name)))))
 
 (provide "JAVA-EXTENSIONS")
+ (defun jproperty-value (obj prop)
+   (%jget-property-value obj prop))
+ 
+ (defun (setf jproperty-value) (value obj prop)
+   (%jset-property-value obj prop value))
+

Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print-object.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp	Sat Jan  3 13:08:56 2009
@@ -50,6 +50,9 @@
     (format stream "~S" (class-name (class-of object))))
   object)
 
+(defmethod print-object ((class java:java-class) stream)
+   (write-string (%write-to-string class) stream))
+
 (defmethod print-object ((class class) stream)
   (print-unreadable-object (class stream :identity t)
     (format stream "~S ~S"
@@ -120,6 +123,16 @@
 (defmethod print-object ((e java:java-exception) stream)
   (if *print-escape*
       (print-unreadable-object (e stream :type t :identity t)
+	(format stream "~A"
+		(java:jcall (java:jmethod "java.lang.Object" "toString")
+			    (java:java-exception-cause e))))
+      (format stream "Java exception '~A'."
+	      (java:jcall (java:jmethod "java.lang.Object" "toString")
+			  (java:java-exception-cause e)))))
+
+(defmethod print-object ((e java:java-exception) stream)
+  (if *print-escape*
+      (print-unreadable-object (e stream :type t :identity t)
         (format stream "~A"
                 (java:jcall (java:jmethod "java.lang.Object" "toString")
                             (java:java-exception-cause e))))



From mevenson at common-lisp.net  Sat Jan  3 13:17:23 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sat, 03 Jan 2009 13:17:23 +0000
Subject: [armedbear-cvs] r11529 - in trunk/abcl: . nbproject
	src/org/armedbear/lisp
Message-ID: <E1LJ6NX-0001df-68@common-lisp.net>

Author: mevenson
Date: Sat Jan  3 13:17:22 2009
New Revision: 11529

Log:
Revert inadvertent r11528.


Modified:
   trunk/abcl/build.properties.in
   trunk/abcl/nbproject/build-impl.xml
   trunk/abcl/nbproject/genfiles.properties
   trunk/abcl/nbproject/project.properties
   trunk/abcl/nbproject/project.xml
   trunk/abcl/netbeans-build.xml
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/Closure.java
   trunk/abcl/src/org/armedbear/lisp/StandardClass.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java
   trunk/abcl/src/org/armedbear/lisp/Version.java
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/java.lisp
   trunk/abcl/src/org/armedbear/lisp/print-object.lisp

Modified: trunk/abcl/build.properties.in
==============================================================================
--- trunk/abcl/build.properties.in	(original)
+++ trunk/abcl/build.properties.in	Sat Jan  3 13:17:22 2009
@@ -1,10 +1,2 @@
 # build.properties
 # $Id: build.properties,v 1.23 2007-03-03 19:19:11 piso Exp $
-
-#additional.jars=${user.home}/work/lsw/lib/bsh-2.0b4.jar:${user.home}/work/lsw/lib/jscheme.jar
-#java.options=-Xmx2g
-
-#abcl.src.version=r14888+possibly-scripting
-
-
-#abcl.build.module=scripting

Modified: trunk/abcl/nbproject/build-impl.xml
==============================================================================
--- trunk/abcl/nbproject/build-impl.xml	(original)
+++ trunk/abcl/nbproject/build-impl.xml	Sat Jan  3 13:17:22 2009
@@ -64,9 +64,7 @@
             </and>
         </condition>
         <condition property="have.tests">
-            <or>
-                <available file="${test.src.dir}"/>
-            </or>
+            <or/>
         </condition>
         <condition property="have.sources">
             <or>
@@ -125,7 +123,6 @@
     </target>
     <target depends="-pre-init,-init-private,-init-user,-init-project,-do-init" name="-init-check">
         <fail unless="src.dir">Must set src.dir</fail>
-        <fail unless="test.src.dir">Must set test.src.dir</fail>
         <fail unless="build.dir">Must set build.dir</fail>
         <fail unless="dist.dir">Must set dist.dir</fail>
         <fail unless="build.classes.dir">Must set build.classes.dir</fail>
@@ -199,11 +196,7 @@
             <attribute default="**" name="testincludes"/>
             <sequential>
                 <junit dir="${work.dir}" errorproperty="tests.failed" failureproperty="tests.failed" fork="true" showoutput="true">
-                    <batchtest todir="${build.test.results.dir}">
-                        <fileset dir="${test.src.dir}" excludes="@{excludes},${excludes}" includes="@{includes}">
-                            <filename name="@{testincludes}"/>
-                        </fileset>
-                    </batchtest>
+                    <batchtest todir="${build.test.results.dir}"/>
                     <classpath>
                         <path path="${run.test.classpath}"/>
                     </classpath>
@@ -508,13 +501,11 @@
         <!-- You can override this target in the ../build.xml file. -->
     </target>
     <target if="do.depend.true" name="-compile-test-depend">
-        <j2seproject3:depend classpath="${javac.test.classpath}" destdir="${build.test.classes.dir}" srcdir="${test.src.dir}"/>
+        <j2seproject3:depend classpath="${javac.test.classpath}" destdir="${build.test.classes.dir}" srcdir=""/>
     </target>
     <target depends="init,compile,-pre-pre-compile-test,-pre-compile-test,-compile-test-depend" if="have.tests" name="-do-compile-test">
-        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" srcdir="${test.src.dir}"/>
-        <copy todir="${build.test.classes.dir}">
-            <fileset dir="${test.src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
-        </copy>
+        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" srcdir=""/>
+        <copy todir="${build.test.classes.dir}"/>
     </target>
     <target name="-post-compile-test">
         <!-- Empty placeholder for easier customization. -->
@@ -528,10 +519,8 @@
     <target depends="init,compile,-pre-pre-compile-test,-pre-compile-test-single" if="have.tests" name="-do-compile-test-single">
         <fail unless="javac.includes">Must select some files in the IDE or set javac.includes</fail>
         <j2seproject3:force-recompile destdir="${build.test.classes.dir}"/>
-        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" excludes="" includes="${javac.includes}" sourcepath="${test.src.dir}" srcdir="${test.src.dir}"/>
-        <copy todir="${build.test.classes.dir}">
-            <fileset dir="${test.src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
-        </copy>
+        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" excludes="" includes="${javac.includes}" sourcepath="" srcdir=""/>
+        <copy todir="${build.test.classes.dir}"/>
     </target>
     <target name="-post-compile-test-single">
         <!-- Empty placeholder for easier customization. -->

Modified: trunk/abcl/nbproject/genfiles.properties
==============================================================================
--- trunk/abcl/nbproject/genfiles.properties	(original)
+++ trunk/abcl/nbproject/genfiles.properties	Sat Jan  3 13:17:22 2009
@@ -3,8 +3,8 @@
 build.xml.stylesheet.CRC32=be360661
 # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml.
 # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you.
-nbproject/build-impl.xml.data.CRC32=742204ce
-nbproject/build-impl.xml.script.CRC32=b94c76f8
+nbproject/build-impl.xml.data.CRC32=71623fcd
+nbproject/build-impl.xml.script.CRC32=7d8238bd
 nbproject/build-impl.xml.stylesheet.CRC32=e55b27f5
 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd
 nbproject/profiler-build-impl.xml.script.CRC32=abda56ed

Modified: trunk/abcl/nbproject/project.properties
==============================================================================
--- trunk/abcl/nbproject/project.properties	(original)
+++ trunk/abcl/nbproject/project.properties	Sat Jan  3 13:17:22 2009
@@ -17,11 +17,10 @@
 dist.dir=dist
 dist.jar=${dist.dir}/abcl.jar
 dist.javadoc.dir=${dist.dir}/javadoc
-excludes=org/armedbear/lisp/scripting/*.java
+excludes=
 file.reference.abcl-src=src
 includes=org/armedbear/lisp/**/*.java,org/armedbear/lisp/**/*.lisp
 jar.compress=true
-javac.classpath=
 # Space-separated list of extra javac options
 javac.compilerargs=
 javac.deprecation=false
@@ -66,4 +65,3 @@
 src.dir=${file.reference.abcl-src}
 src.doc.dir=doc
 src.themes.dir=themes
-test.src.dir=test/src

Modified: trunk/abcl/nbproject/project.xml
==============================================================================
--- trunk/abcl/nbproject/project.xml	(original)
+++ trunk/abcl/nbproject/project.xml	Sat Jan  3 13:17:22 2009
@@ -8,9 +8,7 @@
             <source-roots>
                 <root id="src.dir"/>
             </source-roots>
-            <test-roots>
-                <root id="test.src.dir" name="test/src"/>
-            </test-roots>
+            <test-roots/>
         </data>
     </configuration>
 </project>

Modified: trunk/abcl/netbeans-build.xml
==============================================================================
--- trunk/abcl/netbeans-build.xml	(original)
+++ trunk/abcl/netbeans-build.xml	Sat Jan  3 13:17:22 2009
@@ -5,7 +5,6 @@
 <!-- XXX need way to autodetect NetBeans as installed, as this will
      probably fail otherwise.  -->
   <import file="nbproject/build-impl.xml"/>
-  <import file="nbproject/profiler-build-impl.xml" optional="true"/>
 
   <target name="-post-compile">
     <echo>build.classes.dir: ${build.classes.dir}</echo>

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Sat Jan  3 13:17:22 2009
@@ -452,8 +452,6 @@
         autoload("print-not-readable-object", "PrintNotReadable");
         autoload("probe-file", "probe_file");
         autoload("rational", "FloatFunctions");
-	autoload("read-char-no-hang", "read_char_no_hang");
-	autoload("read-delimited-list", "read_delimited_list");
         autoload("rem", "rem");
         autoload("remhash", "HashTableFunctions");
         autoload("remhash", "HashTableFunctions");
@@ -515,9 +513,6 @@
         autoload(PACKAGE_EXT, "thread-lock", "ThreadLock", true);
         autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true);
         autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
-	autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass");
-	autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
-	autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");
         autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");
         autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass");
         autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");

Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Closure.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Closure.java	Sat Jan  3 13:17:22 2009
@@ -595,8 +595,6 @@
         final LispThread thread = LispThread.currentThread();
         SpecialBinding lastSpecialBinding = thread.lastSpecialBinding;
         Environment ext = new Environment(environment);
-	for (Symbol special: specials)
-	  ext.declareSpecial(special);
         bindRequiredParameters(ext, thread, first, second, third, fourth,
                                fifth, sixth, seventh);
         return bindParametersAndExecute(ext, thread, 

Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sat Jan  3 13:17:22 2009
@@ -123,9 +123,6 @@
   public static final StandardClass BUILT_IN_CLASS =
     addStandardClass(Symbol.BUILT_IN_CLASS, list1(CLASS));
 
-  public static final StandardClass JAVA_CLASS =
-    addStandardClass(Symbol.JAVA_CLASS, list1(CLASS));
-
   public static final StandardClass FORWARD_REFERENCED_CLASS =
     addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list1(CLASS));
 
@@ -283,8 +280,6 @@
                                list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS")))));
     BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT,
                           BuiltInClass.CLASS_T);
-    JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT,
-                          BuiltInClass.CLASS_T);
     CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
                       STANDARD_OBJECT, BuiltInClass.CLASS_T);
     CELL_ERROR.setDirectSlotDefinitions(

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Sat Jan  3 13:17:22 2009
@@ -2900,8 +2900,6 @@
     PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION-CAUSE");
   public static final Symbol JAVA_OBJECT =
     PACKAGE_JAVA.addExternalSymbol("JAVA-OBJECT");
-  public static final Symbol JAVA_CLASS =
-    PACKAGE_JAVA.addExternalSymbol("JAVA-CLASS");
   public static final Symbol JCALL =
     PACKAGE_JAVA.addExternalSymbol("JCALL");
   public static final Symbol JCALL_RAW =

Modified: trunk/abcl/src/org/armedbear/lisp/Version.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Version.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Version.java	Sat Jan  3 13:17:22 2009
@@ -41,6 +41,6 @@
 
   public static String getVersion()
   {
-    return "0.12.25";
+    return "0.13.0-dev";
   }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Sat Jan  3 13:17:22 2009
@@ -201,8 +201,6 @@
 (autoload 'jinterface-implementation "java")
 (export 'jobject-class "JAVA")
 (autoload 'jobject-class "java")
-(export 'jproperty-value "JAVA")
-(autoload 'jproperty-value "java")
 (export 'jclass-superclass "JAVA")
 (autoload 'jclass-superclass "java")
 (export 'jclass-interfaces "JAVA")

Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp	Sat Jan  3 13:17:22 2009
@@ -75,79 +75,6 @@
         (push method-name method-names-and-defs)))
     (apply #'%jnew-proxy interface method-names-and-defs)))
 
-(defun jmake-invocation-handler (function)
-  (%jmake-invocation-handler function))
- 
-(when (autoloadp 'jmake-proxy)
-  (fmakunbound 'jmake-proxy))
- 
-(defgeneric jmake-proxy (interface implementation &optional lisp-this)
-   (:documentation "Returns a proxy Java object implementing the
-   provided interface using methods implemented in Lisp - typically
-   closures, but implementations are free to provide other
-   mechanisms. You can pass an optional 'lisp-this' object that will
-   be passed to the implementing methods as their first argument. If
-   you don't provide this object, NIL will be used. The second
-   argument of the Lisp methods is the name of the Java method being
-   implemented. This has the implication that overloaded methods are
-   merged, so you have to manually discriminate them if you want
-   to. The remaining arguments are java-objects wrapping the method's
-   parameters."))
-
-(defmethod jmake-proxy (interface invocation-handler &optional lisp-this)
-  "Basic implementation that directly uses an invocation handler."
-  (%jmake-proxy (jclass interface) invocation-handler lisp-this))
-
-(defmethod jmake-proxy (interface (implementation function) &optional lisp-this)
-   "Implements a Java interface forwarding method calls to a Lisp function."
-   (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this))
-
- (defmethod jmake-proxy (interface (implementation package) &optional lisp-this)
-   "Implements a Java interface mapping Java method names to symbols
-in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME
-symbol. An error is signaled if no such symbol exists in the package,
-or if the symbol exists but does not name a function."
-
-   (flet ((java->lisp (name)
-	    (with-output-to-string (str)
-	      (let ((last-lower-p nil))
-		(map nil (lambda (char)
-			   (let ((upper-p (char= (char-upcase char) char)))
-			     (when (and last-lower-p upper-p)
-			       (princ "-" str))
-			     (setf last-lower-p (not upper-p))
-			     (princ (char-upcase char) str)))
-		     name)))))
-     (%jmake-proxy (jclass interface)
-		   (jmake-invocation-handler 
-		    (lambda (obj method &rest args)
-		      (let ((sym (find-symbol
-				  (java->lisp method)
-				  implementation)))
-			(unless sym
-			  (error "Symbol ~A, implementation of method ~A, not found in ~A"
-				 (java->lisp method)
-				 method
-				 implementation))
-			(if (fboundp sym)
-			    (apply (symbol-function sym) obj method args)
-			    (error "Function ~A, implementation of method ~A, not found in ~A"
-				   sym method implementation)))))
-		   lisp-this)))
-
-(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this)
-   "Implements a Java interface using closures in an hash-table keyed
-by Java method name."
-   (%jmake-proxy (jclass interface)
- 		(jmake-invocation-handler 
- 		 (lambda (obj method &rest args)
- 		   (let ((fn (gethash method implementation)))
- 		     (if fn
- 			 (apply fn obj args)
-			 (error "Implementation for method ~A not found in ~A"
- 				method implementation)))))
- 		lisp-this))
- 
 (defun jobject-class (obj)
   "Returns the Java class that OBJ belongs to"
   (jcall (jmethod "java.lang.Object" "getClass") obj))
@@ -306,9 +233,3 @@
       (error "Unknown load-from for ~A" class-name)))))
 
 (provide "JAVA-EXTENSIONS")
- (defun jproperty-value (obj prop)
-   (%jget-property-value obj prop))
- 
- (defun (setf jproperty-value) (value obj prop)
-   (%jset-property-value obj prop value))
-

Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print-object.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp	Sat Jan  3 13:17:22 2009
@@ -50,9 +50,6 @@
     (format stream "~S" (class-name (class-of object))))
   object)
 
-(defmethod print-object ((class java:java-class) stream)
-   (write-string (%write-to-string class) stream))
-
 (defmethod print-object ((class class) stream)
   (print-unreadable-object (class stream :identity t)
     (format stream "~S ~S"
@@ -123,16 +120,6 @@
 (defmethod print-object ((e java:java-exception) stream)
   (if *print-escape*
       (print-unreadable-object (e stream :type t :identity t)
-	(format stream "~A"
-		(java:jcall (java:jmethod "java.lang.Object" "toString")
-			    (java:java-exception-cause e))))
-      (format stream "Java exception '~A'."
-	      (java:jcall (java:jmethod "java.lang.Object" "toString")
-			  (java:java-exception-cause e)))))
-
-(defmethod print-object ((e java:java-exception) stream)
-  (if *print-escape*
-      (print-unreadable-object (e stream :type t :identity t)
         (format stream "~A"
                 (java:jcall (java:jmethod "java.lang.Object" "toString")
                             (java:java-exception-cause e))))



From mevenson at common-lisp.net  Sat Jan  3 18:16:11 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sat, 03 Jan 2009 18:16:11 +0000
Subject: [armedbear-cvs] r11530 - in trunk/abcl: . scripts test/lisp
	test/lisp/ansi test/lisp/cl-bench
Message-ID: <E1LJB2h-0000YR-EV@common-lisp.net>

Author: mevenson
Date: Sat Jan  3 18:16:10 2009
New Revision: 11530

Log:
'abcl.test' now invokes both Java and Lisp based tests.

First stab at a collected test infrastructure for ABCL using ASDF packaging.

Currently, only the GCL ANSI-TEST suite really works: create a sibling
directory to the 'abcl' top-level directory called 'ansi-tests' to get
them to run automagically.  



Added:
   trunk/abcl/abcl.asd
   trunk/abcl/scripts/ansi-tests-compiled.lisp   (contents, props changed)
   trunk/abcl/scripts/ansi-tests-interpreted.lisp   (contents, props changed)
   trunk/abcl/test/lisp/
   trunk/abcl/test/lisp/ansi/
   trunk/abcl/test/lisp/ansi/package.lisp   (contents, props changed)
   trunk/abcl/test/lisp/cl-bench/
   trunk/abcl/test/lisp/cl-bench.asd
Removed:
   trunk/abcl/scripts/update-version
Modified:
   trunk/abcl/build.xml

Added: trunk/abcl/abcl.asd
==============================================================================
--- (empty file)
+++ trunk/abcl/abcl.asd	Sat Jan  3 18:16:10 2009
@@ -0,0 +1,39 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP -*-
+;;; $Id$
+
+(require 'asdf)
+(defpackage :abcl-asdf
+  (:use :cl :asdf))
+(in-package :abcl-asdf)
+
+(defsystem :abcl
+  :documentation "Wrapper for all ABCL ASDF definitions."
+  :version "0.2.0")
+
+(defmethod perform :after ((o load-op) (c (eql (find-system 'abcl))))
+  (asdf:oos 'asdf:load-op :test-abcl))
+
+(defsystem :test-abcl
+  :documentation "A collection of test suites for ABCL." 
+  :version "0.3"
+  :components
+     ((:module ansi-tests :pathname "test/lisp/ansi/"
+	       :documentation "GCL ANSI test suite"
+	       :components
+	      ((:file "package")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'abcl))))
+  "Invoke tests with:  (asdf:oos 'asdf:test-op :test-abcl)."
+  (funcall (intern (symbol-name 'run-ansi-tests) 
+		   :abcl.tests.ansi-tests)))
+
+;;; Works for: abcl, sbcl, clisp
+(defsystem :build-abcl 
+  :documentation "Build ABCL from a Lisp."
+  :components 
+	   ((:module build :pathname ""  :components
+		     ((:file "build-abcl") 
+		      (:file "customizations" :depends-on ("build-abcl"))))))
+
+
+

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Sat Jan  3 18:16:10 2009
@@ -82,7 +82,7 @@
 
       <!-- Set from commandline via -D or in 'build.properties' -->
       <property name="build.version" value="abcl.svn"/>
-      <echo>Build-Version: ${build.version}</echo>
+      <echo>Implementation-Source: ${version.src}</echo>
     </target>
 
     <target name="abcl.stamp.hostname">
@@ -421,6 +421,7 @@
     <target name="abcl.test.pre-compile">
       <mkdir dir="${abcl.ext.dir}"/>
       <get src="http://downloads.sourceforge.net/junit/junit-4.5.jar?modtime=1218209625"
+	   usetimestamp="true"
 	  dest="${junit-4.5.path}"/>
     </target>
 	
@@ -439,6 +440,8 @@
       <path refid="abcl.test.compile.classpath"/>
       <pathelement location="${abcl.test.classes.dir}"/>
     </path>
+
+    <target name="abcl.test" depends="abcl.test.java,abcl.test.lisp"/>
 	
     <target name="abcl.test.java" depends="abcl.test.compile">
       <java fork="true"
@@ -448,6 +451,30 @@
       </java>
     </target>
 
+    <target name="abcl.test.lisp" depends="abcl.test.lisp.asdf"/>
+
+    <target name="abcl.test.lisp.asdf" depends="abcl.jar">
+    </target>
+
+    <target name="abcl.test.ansi.interpreted">
+      <java fork="true"
+	    classpathref="abcl.classpath.dist"
+	    classname="org.armedbear.lisp.Main">
+	<arg value="--noinit"/>
+	<arg value="--load scripts/ansi-tests-interpreted.lisp "/>
+      </java>
+    </target>
+
+    <target name="abcl.test.ansi.interpreted">
+      <java fork="true"
+	    classpathref="abcl.classpath.dist"
+	    classname="org.armedbear.lisp.Main">
+	<arg value="--noinit"/>
+	<arg value="--load scripts/ansi-tests-compiled.lisp "/>
+      </java>
+    </target>
+
+
     <import file="netbeans-build.xml" optional="true"/> 
 <!--    <import file="j-build.xml" optional="true"/>  -->
     <import file="not.org-build.xml" optional="true"/> 

Added: trunk/abcl/scripts/ansi-tests-compiled.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/scripts/ansi-tests-compiled.lisp	Sat Jan  3 18:16:10 2009
@@ -0,0 +1,4 @@
+(require 'asdf)
+(asdf:oos 'asdf:load-op :abcl)
+(abcl.tests.ansi-tests:run :compile-tests t)
+(ext:exit)
\ No newline at end of file

Added: trunk/abcl/scripts/ansi-tests-interpreted.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/scripts/ansi-tests-interpreted.lisp	Sat Jan  3 18:16:10 2009
@@ -0,0 +1,4 @@
+(require 'asdf)
+(asdf:oos 'asdf:load-op :abcl)
+(asdf:oos 'asdf:test-op :abcl :force t)
+(ext:exit)
\ No newline at end of file

Added: trunk/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/ansi/package.lisp	Sat Jan  3 18:16:10 2009
@@ -0,0 +1,47 @@
+(defpackage :abcl.tests.ansi-tests
+  (:use :cl :asdf)
+  (:nicknames "ansi-tests" "abcl-ansi-tests")
+  (:export :run))
+
+(in-package :abcl.tests.ansi-tests)
+
+(defparameter *ansi-tests-master-source-location*
+  "<svn://common-lisp.net/project/ansi-test/svn/trunk/ansi-tests>")  
+
+(defparameter *ansi-tests-directory*
+  (merge-pathnames
+   #p"../ansi-tests/"
+   (asdf:component-pathname (asdf:find-system :abcl))))
+
+(defun run (&optional (compile-tests nil)) 
+  "Run the ANSI-TESTS suite, found in *ANSI-TESTS-DIRECTORY*.
+Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL."
+  (let ((original-pathname-defaults *default-pathname-defaults*)
+	(ansi-tests-directory *ansi-tests-directory*)
+	(boot-file (if compile-tests "compileit.lsp" "doit.lsp")))
+    (handler-case 
+	(progn
+	  (setf  *default-pathname-defaults*
+		 (merge-pathnames ansi-tests-directory 
+				  *default-pathname-defaults*))
+	  (warn 
+	   (format nil "Speculative invocation of '~A' in ~A follows."
+		   boot-file
+		   ansi-tests-directory))
+;; XXX -- what to invoke on win32?
+;;	  (run-shell-command "make clean" :directory ansi-tests-directory)
+	  (time (load boot-file)))
+      (file-error (e)
+		(error 
+		 (format nil
+			 "Failed to find the GCL ANSI tests in '~A'.
+Because ~A.
+To resolve, please locally obtain ~A, 
+and set the value of *ANSI-TESTS-DIRECTORY* to that location."
+		 ansi-tests-directory e 
+		 *ansi-tests-master-source-location*))))
+    (setf *default-pathname-defaults*
+	  original-pathname-defaults)))
+		   
+	     
+

Added: trunk/abcl/test/lisp/cl-bench.asd
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/cl-bench.asd	Sat Jan  3 18:16:10 2009
@@ -0,0 +1,28 @@
+(defpackage :cl-bench-asdf 
+  (:use :cl :asdf))
+
+(in-package :cl-bench-asdf)
+
+(defsystem :cl-bench
+  :documentation "http://www.chez.com/emarsden/downloads/cl-bench.tar.gz"
+  :version "20081231a"
+  :components 
+  ((:module cl-bench-source :pathname "" :components
+	    ((:file "defpackage")
+	     (:file "do-compilation-script")
+	     (:file "do-execute-script")
+	     (:file "do-interpret-script")
+	     (:file "generate")
+	     (:file "graph-report")
+	     (:file "pdf-report")
+	     (:file "report")
+	     (:file "support")
+	     (:file "tests")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'cl-bench))))
+  "Invoke tests with:  (asdf:operate 'asdf:test-op :cl-bench)."
+  (asdf:oos 'asdf:load-op :cl-bench)
+  (load "sysdep/setup-ablisp.lisp")
+;  (load "do-compilation-script.lisp")
+  (load "do-execute-script"))
+



From vvoutilainen at common-lisp.net  Sat Jan  3 18:41:50 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 03 Jan 2009 18:41:50 +0000
Subject: [armedbear-cvs] r11531 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJBRW-0002E4-BG@common-lisp.net>

Author: vvoutilainen
Date: Sat Jan  3 18:41:49 2009
New Revision: 11531

Log:
In preparation for further refactorings, a tiny change
to p2-plus.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan  3 18:41:49 2009
@@ -6715,9 +6715,8 @@
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
              ((fixnum-type-p type2)
-              (compile-form arg1 'stack nil)
-              (maybe-emit-clear-values arg1 arg2)
-              (compile-form arg2 'stack :int)
+	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
+							 arg2 'stack :int)
               (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))



From vvoutilainen at common-lisp.net  Sat Jan  3 19:02:39 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 03 Jan 2009 19:02:39 +0000
Subject: [armedbear-cvs] r11532 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJBlf-0003Ep-Sq@common-lisp.net>

Author: vvoutilainen
Date: Sat Jan  3 19:02:39 2009
New Revision: 11532

Log:
Helper function for p2-test-minusp/plusp/zerop.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan  3 19:02:39 2009
@@ -3193,32 +3193,23 @@
             (t
              (p2-test-predicate form "listp"))))))
 
-(defun p2-test-minusp (form)
+(defun p2-test-minusp/plusp/zerop (form instruction predicate)
   (when (check-arg-count form 1)
     (let ((arg (%cadr form)))
       (cond ((fixnum-type-p (derive-compiler-type arg))
 	     (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-             'ifge)
+             instruction)
             (t
-             (p2-test-predicate form "minusp"))))))
+             (p2-test-predicate form predicate))))))
+
+(defun p2-test-minusp (form)
+  (p2-test-minusp/plusp/zerop form 'ifge "minusp"))
 
 (defun p2-test-plusp (form)
-  (when (check-arg-count form 1)
-    (let ((arg (%cadr form)))
-      (cond ((fixnum-type-p (derive-compiler-type arg))
-	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-             'ifle)
-            (t
-             (p2-test-predicate form "plusp"))))))
+  (p2-test-minusp/plusp/zerop form 'ifle "plusp"))
 
 (defun p2-test-zerop (form)
-  (when (check-arg-count form 1)
-    (let ((arg (%cadr form)))
-      (cond ((fixnum-type-p (derive-compiler-type arg))
-	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-             'ifne)
-            (t
-             (p2-test-predicate form "zerop"))))))
+  (p2-test-minusp/plusp/zerop form 'ifne "zerop"))
 
 (defun p2-test-numberp (form)
   (p2-test-predicate form "numberp"))



From vvoutilainen at common-lisp.net  Sat Jan  3 19:30:59 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 03 Jan 2009 19:30:59 +0000
Subject: [armedbear-cvs] r11533 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJCD5-0004lW-LP@common-lisp.net>

Author: vvoutilainen
Date: Sat Jan  3 19:30:59 2009
New Revision: 11533

Log:
Helper macro for p2-test-minusp/plusp/zerop/oddp/evenp.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan  3 19:30:59 2009
@@ -3152,27 +3152,28 @@
 (defun p2-test-endp (form)
   (p2-test-predicate form "endp"))
 
+(defmacro p2-test-integer-predicate (form predicate &body instructions)
+  (let ((tmpform (gensym)))
+    `(let ((,tmpform ,form))
+       (when (check-arg-count ,tmpform 1)
+	 (let ((arg (%cadr ,tmpform)))
+	   (cond ((fixnum-type-p (derive-compiler-type arg))
+		  (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
+		  , at instructions)
+		 (t
+		  (p2-test-predicate ,tmpform ,predicate))))))))
+
 (defun p2-test-evenp (form)
-  (when (check-arg-count form 1)
-    (let ((arg (%cadr form)))
-      (cond ((fixnum-type-p (derive-compiler-type arg))
-	     (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-             (emit-push-constant-int 1)
-             (emit 'iand)
-             'ifne)
-            (t
-             (p2-test-predicate form "evenp"))))))
+  (p2-test-integer-predicate form "evenp"
+			     (emit-push-constant-int 1)
+			     (emit 'iand)
+			     'ifne))
 
 (defun p2-test-oddp (form)
-  (when (check-arg-count form 1)
-    (let ((arg (%cadr form)))
-      (cond ((fixnum-type-p (derive-compiler-type arg))
-	     (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-             (emit-push-constant-int 1)
-             (emit 'iand)
-             'ifeq)
-            (t
-             (p2-test-predicate form "oddp"))))))
+  (p2-test-integer-predicate form "oddp"
+			     (emit-push-constant-int 1)
+			     (emit 'iand)
+			     'ifeq))
 
 (defun p2-test-floatp (form)
   (p2-test-predicate form "floatp"))
@@ -3193,23 +3194,14 @@
             (t
              (p2-test-predicate form "listp"))))))
 
-(defun p2-test-minusp/plusp/zerop (form instruction predicate)
-  (when (check-arg-count form 1)
-    (let ((arg (%cadr form)))
-      (cond ((fixnum-type-p (derive-compiler-type arg))
-	     (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-             instruction)
-            (t
-             (p2-test-predicate form predicate))))))
-
 (defun p2-test-minusp (form)
-  (p2-test-minusp/plusp/zerop form 'ifge "minusp"))
+  (p2-test-integer-predicate form "minusp" 'ifge))
 
 (defun p2-test-plusp (form)
-  (p2-test-minusp/plusp/zerop form 'ifle "plusp"))
+  (p2-test-integer-predicate form "plusp" 'ifle))
 
 (defun p2-test-zerop (form)
-  (p2-test-minusp/plusp/zerop form 'ifne "zerop"))
+  (p2-test-integer-predicate form "zerop" 'ifne))
 
 (defun p2-test-numberp (form)
   (p2-test-predicate form "numberp"))



From vvoutilainen at common-lisp.net  Sat Jan  3 20:55:49 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 03 Jan 2009 20:55:49 +0000
Subject: [armedbear-cvs] r11534 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJDXB-00016k-Ng@common-lisp.net>

Author: vvoutilainen
Date: Sat Jan  3 20:55:49 2009
New Revision: 11534

Log:
Helper function for creating a new fixnum and emitting
dup immediately after. I'll also at this point note
my copyright on the file, after numerous refactorings
done, and more to come.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan  3 20:55:49 2009
@@ -1,6 +1,7 @@
 ;;; compiler-pass2.lisp
 ;;;
 ;;; Copyright (C) 2003-2008 Peter Graves
+;;; Copyright (C) 2008 Ville Voutilainen
 ;;; $Id$
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -1929,6 +1930,11 @@
         (setf (gethash local-function ht) g)))
     g))
 
+(defun new-fixnum (&optional (test-val t))
+  (when test-val
+    (emit 'new +lisp-fixnum-class+)
+    (emit 'dup)))
+
 (defknown declare-fixnum (fixnum) string)
 (defun declare-fixnum (n)
   (declare (type fixnum n))
@@ -1946,8 +1952,7 @@
                (emit-push-constant-int n)
                (emit 'aaload))
               (t
-               (emit 'new +lisp-fixnum-class+)
-               (emit 'dup)
+	       (new-fixnum)
                (emit-push-constant-int n)
                (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
         (emit 'putstatic *this-class* g +lisp-fixnum+)
@@ -5007,9 +5012,7 @@
                 (<= -31 constant-shift 31)
                 (fixnum-type-p type1)
                 (fixnum-type-p result-type))
-           (when (null representation)
-             (emit 'new +lisp-fixnum-class+)
-             (emit 'dup))
+	   (new-fixnum (null representation))
            (compile-form arg1 'stack :int)
            (cond ((plusp constant-shift)
                   (compile-form arg2 'stack :int)
@@ -5051,9 +5054,7 @@
            (emit-move-from-stack target representation))
           ((and (fixnum-type-p type1)
                 low2 high2 (<= -31 low2 high2 0)) ; Negative shift.
-           (when (null representation)
-             (emit 'new +lisp-fixnum-class+)
-             (emit 'dup))
+	   (new-fixnum (null representation))
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 						      arg2 'stack :int)
            (emit 'ineg)
@@ -5123,9 +5124,7 @@
                ((and (fixnum-type-p type1) (fixnum-type-p type2))
                 ;;                     (format t "p2-logand fixnum case~%")
                 ;; Both arguments are fixnums.
-                (when (null representation)
-                  (emit 'new +lisp-fixnum-class+)
-                  (emit 'dup))
+		(new-fixnum (null representation))
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'iand)
@@ -5136,9 +5135,7 @@
                     (and (fixnum-type-p type2)
                          (compiler-subtypep type2 'unsigned-byte)))
                 ;; One of the arguments is a positive fixnum.
-                (when (null representation)
-                  (emit 'new +lisp-fixnum-class+)
-                  (emit 'dup))
+		(new-fixnum (null representation))
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'iand)
@@ -5228,9 +5225,7 @@
                                           (fixnum-constant-value type2))
                                   target representation))
                ((and (fixnum-type-p type1) (fixnum-type-p type2))
-                (when (null representation)
-                  (emit 'new +lisp-fixnum-class+)
-                  (emit 'dup))
+		(new-fixnum (null representation))
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'ior)
@@ -5305,9 +5300,7 @@
                 (emit 'ixor))
                ((and (fixnum-type-p type1) (fixnum-type-p type2))
 ;;                 (format t "p2-logxor case 2~%")
-                (when (null representation)
-                  (emit 'new +lisp-fixnum-class+)
-                  (emit 'dup))
+		(new-fixnum (null representation))
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							   arg2 'stack :int)
                 (emit 'ixor)
@@ -5341,9 +5334,7 @@
     (return-from p2-lognot))
   (cond ((and (fixnum-type-p (derive-compiler-type form)))
          (let ((arg (%cadr form)))
-           (when (null representation)
-             (emit 'new +lisp-fixnum-class+)
-             (emit 'dup))
+	   (new-fixnum (null representation))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
            (emit 'iconst_m1)
            (emit 'ixor)
@@ -5381,9 +5372,7 @@
            (compile-constant 0 target representation))
           ((and size position)
            (cond ((<= (+ position size) 31)
-                  (when (null representation)
-                    (emit 'new +lisp-fixnum-class+)
-                    (emit 'dup))
+		  (new-fixnum (null representation))
 		  (compile-forms-and-maybe-emit-clear-values size-arg nil nil
 							     position-arg nil nil
 							     arg3 'stack :int)
@@ -5395,10 +5384,7 @@
 		  (emit-fixnum-init representation)
                   (emit-move-from-stack target representation))
                  ((<= (+ position size) 63)
-                  (when (and (null representation) (<= size 31))
-                    ;; Result is a fixnum.
-                    (emit 'new +lisp-fixnum-class+)
-                    (emit 'dup))
+		  (new-fixnum (and (null representation) (<= size 31)))
 		  (compile-forms-and-maybe-emit-clear-values size-arg nil nil
 							     position-arg nil nil
 							     arg3 'stack :long)
@@ -6492,8 +6478,7 @@
                    (fixnum-type-p type2))
               (cond ((fixnum-type-p result-type)
                      (unless (eq representation :int)
-                       (emit 'new +lisp-fixnum-class+)
-                       (emit 'dup))
+		       (new-fixnum))
 		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 								arg2 'stack :int)
                      (emit 'imul)
@@ -6554,9 +6539,7 @@
                     (let* ((*register* *register*)
                            (reg1 (allocate-register))
                            (reg2 (allocate-register)))
-                      (when (null representation)
-                        (emit 'new +lisp-fixnum-class+)
-                        (emit 'dup))
+		      (new-fixnum (null representation))
                       (compile-form arg1 'stack :int)
                       (emit 'dup)
                       (emit 'istore reg1)
@@ -6651,9 +6634,7 @@
              ((and (fixnum-type-p type1) (fixnum-type-p type2))
               (cond ((or (eq representation :int)
                          (fixnum-type-p result-type))
-                     (when (null representation)
-                       (emit 'new +lisp-fixnum-class+)
-                       (emit 'dup))
+		     (new-fixnum (null representation))
 		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 								arg2 'stack :int)
                      (emit 'iadd)
@@ -6729,9 +6710,7 @@
              ((and (fixnum-type-p type)
                    (integer-type-low type)
                    (> (integer-type-low type) most-negative-fixnum))
-              (when (null representation)
-                (emit 'new +lisp-fixnum-class+)
-                (emit 'dup))
+	      (new-fixnum (null representation))
               (compile-form arg 'stack :int)
               (emit 'ineg)
 	      (emit-fixnum-init representation)
@@ -6766,9 +6745,7 @@
              ((and (fixnum-type-p type1) (fixnum-type-p type2))
               (cond ((or (eq representation :int)
                          (fixnum-type-p result-type))
-                     (when (null representation)
-                       (emit 'new +lisp-fixnum-class+)
-                       (emit 'dup))
+		     (new-fixnum (null representation))
 		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 								arg2 'stack :int)
                      (emit 'isub)
@@ -6886,9 +6863,7 @@
              (maybe-emit-clear-values arg1 arg2 arg3)
              (emit-invokevirtual class "setCharAt" '("I" "C") nil)
              (when target
-               (when (null representation)
-                 (emit 'new +lisp-fixnum-class+)
-                 (emit 'dup))
+	       (new-fixnum (null representation))
                (emit 'iload value-register)
                (case representation
                  (:char)
@@ -7068,9 +7043,7 @@
                   (emit-invokevirtual +lisp-object-class+ "aset" (list "I" +lisp-object+) nil)))
            (when value-register
              (cond ((fixnum-type-p type3)
-                    (when (null representation)
-                      (emit 'new +lisp-fixnum-class+)
-                      (emit 'dup))
+		    (new-fixnum (null representation))
                     (emit 'iload value-register)
 		    (emit-fixnum-init representation))
                    (t
@@ -7400,8 +7373,7 @@
                    (:boolean
                     (emit 'iconst_1))
                    (t
-                    (emit 'new +lisp-fixnum-class+)
-                    (emit 'dup)
+		    (new-fixnum)
                     (emit 'iload (variable-register variable))
                     (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
                  (emit-move-from-stack target representation))
@@ -7570,8 +7542,7 @@
              (emit 'iload (variable-register variable))
              (emit 'i2l))
             (t
-             (emit 'new +lisp-fixnum-class+)
-             (emit 'dup)
+	     (new-fixnum)
              (aver (variable-register variable))
              (emit 'iload (variable-register variable))
              (emit-invokespecial-init +lisp-fixnum-class+ '("I"))
@@ -7592,8 +7563,7 @@
                    (t
                     (dformat t "p2-setq constructing boxed fixnum for ~S~%"
                              (variable-name variable))
-                    (emit 'new +lisp-fixnum-class+)
-                    (emit 'dup)
+		    (new-fixnum)
                     (aver (variable-register variable))
                     (emit 'iload (variable-register variable))
                     (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
@@ -7609,8 +7579,7 @@
                    (t
                     (dformat t "p2-setq constructing boxed fixnum for ~S~%"
                              (variable-name variable))
-                    (emit 'new +lisp-fixnum-class+)
-                    (emit 'dup)
+		    (new-fixnum)
                     (aver (variable-register variable))
                     (emit 'iload (variable-register variable))
                     (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
@@ -7689,8 +7658,7 @@
   (cond ((check-arg-count form 1)
          (let ((arg (%cadr form)))
            (unless (eq representation :int)
-             (emit 'new +lisp-fixnum-class+)
-             (emit 'dup))
+	     (new-fixnum))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
            (emit-invokevirtual +lisp-object-class+ "sxhash" nil "I")
            (unless (eq representation :int)
@@ -7815,9 +7783,7 @@
            (compile-constant (char-code arg) target representation))
           ((and (< *safety* 3)
                 (eq (derive-compiler-type arg) 'character))
-           (when (null representation)
-             (emit 'new +lisp-fixnum-class+)
-             (emit 'dup))
+	   (new-fixnum (null representation))
            (compile-form arg 'stack :char)
 	   (emit-fixnum-init representation)
            (emit-move-from-stack target representation))



From mevenson at common-lisp.net  Sun Jan  4 11:08:09 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 04 Jan 2009 11:08:09 +0000
Subject: [armedbear-cvs] r11535 - trunk/abcl
Message-ID: <E1LJQq1-0005eS-8R@common-lisp.net>

Author: mevenson
Date: Sun Jan  4 11:08:08 2009
New Revision: 11535

Log:
Intermediate fix to remove double dupliation.

Modified:
   trunk/abcl/build.xml

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Sun Jan  4 11:08:08 2009
@@ -453,24 +453,26 @@
 
     <target name="abcl.test.lisp" depends="abcl.test.lisp.asdf"/>
 
-    <target name="abcl.test.lisp.asdf" depends="abcl.jar">
+    <target name="abcl.test.lisp.asdf" depends="abcl.jar,abcl.test.ansi.interpreted">
     </target>
 
     <target name="abcl.test.ansi.interpreted">
-      <java fork="true"
+      <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
 	<arg value="--noinit"/>
-	<arg value="--load scripts/ansi-tests-interpreted.lisp "/>
+	<arg value="--load"/>
+	<arg value="scripts/ansi-tests-interpreted.lisp "/>
       </java>
     </target>
 
-    <target name="abcl.test.ansi.interpreted">
-      <java fork="true"
+    <target name="abcl.test.ansi.compiled">
+      <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
 	<arg value="--noinit"/>
-	<arg value="--load scripts/ansi-tests-compiled.lisp "/>
+	<arg value="--load"/>
+	<arg value="scripts/ansi-tests-compiled.lisp "/>
       </java>
     </target>
 



From mevenson at common-lisp.net  Sun Jan  4 12:14:41 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 04 Jan 2009 12:14:41 +0000
Subject: [armedbear-cvs] r11537 - in trunk/abcl: . nbproject scripts
	test/lisp/ansi
Message-ID: <E1LJRsP-0000rP-E9@common-lisp.net>

Author: mevenson
Date: Sun Jan  4 12:14:40 2009
New Revision: 11537

Log:
build.xml's target 'abcl.test' invokes the GCL ANSI-TEST interpreted tests by default.

In order for these tests to work, you will need a sibling directory of
'abcl' called 'ansi-tests' which contains the GCL ANSI-TEST suite from
<svn://common-lisp.net/project/ansi-test/svn/trunk/ansi-tests>.


Modified:
   trunk/abcl/abcl.asd
   trunk/abcl/build.xml
   trunk/abcl/nbproject/project.properties
   trunk/abcl/scripts/ansi-tests-compiled.lisp
   trunk/abcl/scripts/ansi-tests-interpreted.lisp
   trunk/abcl/test/lisp/ansi/package.lisp

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Sun Jan  4 12:14:40 2009
@@ -10,22 +10,40 @@
   :documentation "Wrapper for all ABCL ASDF definitions."
   :version "0.2.0")
 
-(defmethod perform :after ((o load-op) (c (eql (find-system 'abcl))))
+(defmethod perform :around ((o load-op) (c (eql (find-system 'abcl))))
+  (call-next-method)
+  (format t "DEBUG: load-op around :abcl.~%")
   (asdf:oos 'asdf:load-op :test-abcl))
 
+(defmethod perform ((o test-op) (c (eql (find-system 'abcl))))
+  (format t "DEBUG: test-op :abcl.~%")
+  (asdf:oos 'asdf:load-op :test-abcl :force t)
+  (asdf:oos 'asdf:test-op :ansi-test-compiled :force t))
+
 (defsystem :test-abcl
   :documentation "A collection of test suites for ABCL." 
   :version "0.3"
-  :components
+  :depends-on (:ansi-test-compiled :ansi-test-interpreted))
+
+(defmethod perform :after ((o test-op) (c (eql (find-system 'test-abcl))))
+  (asdf:oos 'asdf:load-op :ansi-test-interpreted :force t)
+  (asdf:oos 'asdf:load-op :ansi-test-compiled :force t))
+
+(defsystem :ansi-test :version "0.1" :components
      ((:module ansi-tests :pathname "test/lisp/ansi/"
-	       :documentation "GCL ANSI test suite"
+	       :documentation "GCL ANSI test suite."
 	       :components
 	      ((:file "package")))))
+(defsystem :ansi-test-interpreted :version "0,1" :depends-on (ansi-test))
+(defsystem :ansi-test-compiled :version "0.1" :depends-on (ansi-test))
 
-(defmethod perform ((o test-op) (c (eql (find-system 'abcl))))
-  "Invoke tests with:  (asdf:oos 'asdf:test-op :test-abcl)."
-  (funcall (intern (symbol-name 'run-ansi-tests) 
-		   :abcl.tests.ansi-tests)))
+(defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-interpreted))))
+  (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
+	   :compile-tests nil))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-compiled))))
+  (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
+	   :compile-tests t))
 
 ;;; Works for: abcl, sbcl, clisp
 (defsystem :build-abcl 

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Sun Jan  4 12:14:40 2009
@@ -462,7 +462,7 @@
 	    classname="org.armedbear.lisp.Main">
 	<arg value="--noinit"/>
 	<arg value="--load"/>
-	<arg value="scripts/ansi-tests-interpreted.lisp "/>
+	<arg value="${basedir}/scripts/ansi-tests-interpreted.lisp "/>
       </java>
     </target>
 
@@ -472,7 +472,7 @@
 	    classname="org.armedbear.lisp.Main">
 	<arg value="--noinit"/>
 	<arg value="--load"/>
-	<arg value="scripts/ansi-tests-compiled.lisp "/>
+	<arg value="${basedir}/scripts/ansi-tests-compiled.lisp "/>
       </java>
     </target>
 

Modified: trunk/abcl/nbproject/project.properties
==============================================================================
--- trunk/abcl/nbproject/project.properties	(original)
+++ trunk/abcl/nbproject/project.properties	Sun Jan  4 12:14:40 2009
@@ -21,6 +21,7 @@
 file.reference.abcl-src=src
 includes=org/armedbear/lisp/**/*.java,org/armedbear/lisp/**/*.lisp
 jar.compress=true
+javac.classpath=
 # Space-separated list of extra javac options
 javac.compilerargs=
 javac.deprecation=false

Modified: trunk/abcl/scripts/ansi-tests-compiled.lisp
==============================================================================
--- trunk/abcl/scripts/ansi-tests-compiled.lisp	(original)
+++ trunk/abcl/scripts/ansi-tests-compiled.lisp	Sun Jan  4 12:14:40 2009
@@ -1,4 +1,5 @@
 (require 'asdf)
 (asdf:oos 'asdf:load-op :abcl)
-(abcl.tests.ansi-tests:run :compile-tests t)
+(asdf:oos 'asdf:load-op :test-abcl)
+(asdf:oos 'asdf:test-op :ansi-test-compiled :force t)
 (ext:exit)
\ No newline at end of file

Modified: trunk/abcl/scripts/ansi-tests-interpreted.lisp
==============================================================================
--- trunk/abcl/scripts/ansi-tests-interpreted.lisp	(original)
+++ trunk/abcl/scripts/ansi-tests-interpreted.lisp	Sun Jan  4 12:14:40 2009
@@ -1,4 +1,5 @@
 (require 'asdf)
 (asdf:oos 'asdf:load-op :abcl)
-(asdf:oos 'asdf:test-op :abcl :force t)
-(ext:exit)
\ No newline at end of file
+(asdf:oos 'asdf:load-op :test-abcl)
+(asdf:oos 'asdf:test-op :ansi-test-interpreted :force t)
+(ext:exit)

Modified: trunk/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/package.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/package.lisp	Sun Jan  4 12:14:40 2009
@@ -13,7 +13,7 @@
    #p"../ansi-tests/"
    (asdf:component-pathname (asdf:find-system :abcl))))
 
-(defun run (&optional (compile-tests nil)) 
+(defun run (&key (compile-tests nil)) 
   "Run the ANSI-TESTS suite, found in *ANSI-TESTS-DIRECTORY*.
 Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL."
   (let ((original-pathname-defaults *default-pathname-defaults*)



From mevenson at common-lisp.net  Sun Jan  4 12:33:37 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 04 Jan 2009 12:33:37 +0000
Subject: [armedbear-cvs] r11538 - trunk/abcl/nbproject
Message-ID: <E1LJSAj-0001w5-S8@common-lisp.net>

Author: mevenson
Date: Sun Jan  4 12:33:37 2009
New Revision: 11538

Log:
Added JUnit tests to Netbeans project.


Modified:
   trunk/abcl/nbproject/build-impl.xml
   trunk/abcl/nbproject/genfiles.properties
   trunk/abcl/nbproject/project.properties
   trunk/abcl/nbproject/project.xml

Modified: trunk/abcl/nbproject/build-impl.xml
==============================================================================
--- trunk/abcl/nbproject/build-impl.xml	(original)
+++ trunk/abcl/nbproject/build-impl.xml	Sun Jan  4 12:33:37 2009
@@ -64,7 +64,9 @@
             </and>
         </condition>
         <condition property="have.tests">
-            <or/>
+            <or>
+                <available file="${test.src.dir}"/>
+            </or>
         </condition>
         <condition property="have.sources">
             <or>
@@ -123,6 +125,7 @@
     </target>
     <target depends="-pre-init,-init-private,-init-user,-init-project,-do-init" name="-init-check">
         <fail unless="src.dir">Must set src.dir</fail>
+        <fail unless="test.src.dir">Must set test.src.dir</fail>
         <fail unless="build.dir">Must set build.dir</fail>
         <fail unless="dist.dir">Must set dist.dir</fail>
         <fail unless="build.classes.dir">Must set build.classes.dir</fail>
@@ -196,7 +199,11 @@
             <attribute default="**" name="testincludes"/>
             <sequential>
                 <junit dir="${work.dir}" errorproperty="tests.failed" failureproperty="tests.failed" fork="true" showoutput="true">
-                    <batchtest todir="${build.test.results.dir}"/>
+                    <batchtest todir="${build.test.results.dir}">
+                        <fileset dir="${test.src.dir}" excludes="@{excludes},${excludes}" includes="@{includes}">
+                            <filename name="@{testincludes}"/>
+                        </fileset>
+                    </batchtest>
                     <classpath>
                         <path path="${run.test.classpath}"/>
                     </classpath>
@@ -501,11 +508,13 @@
         <!-- You can override this target in the ../build.xml file. -->
     </target>
     <target if="do.depend.true" name="-compile-test-depend">
-        <j2seproject3:depend classpath="${javac.test.classpath}" destdir="${build.test.classes.dir}" srcdir=""/>
+        <j2seproject3:depend classpath="${javac.test.classpath}" destdir="${build.test.classes.dir}" srcdir="${test.src.dir}"/>
     </target>
     <target depends="init,compile,-pre-pre-compile-test,-pre-compile-test,-compile-test-depend" if="have.tests" name="-do-compile-test">
-        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" srcdir=""/>
-        <copy todir="${build.test.classes.dir}"/>
+        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" srcdir="${test.src.dir}"/>
+        <copy todir="${build.test.classes.dir}">
+            <fileset dir="${test.src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
+        </copy>
     </target>
     <target name="-post-compile-test">
         <!-- Empty placeholder for easier customization. -->
@@ -519,8 +528,10 @@
     <target depends="init,compile,-pre-pre-compile-test,-pre-compile-test-single" if="have.tests" name="-do-compile-test-single">
         <fail unless="javac.includes">Must select some files in the IDE or set javac.includes</fail>
         <j2seproject3:force-recompile destdir="${build.test.classes.dir}"/>
-        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" excludes="" includes="${javac.includes}" sourcepath="" srcdir=""/>
-        <copy todir="${build.test.classes.dir}"/>
+        <j2seproject3:javac classpath="${javac.test.classpath}" debug="true" destdir="${build.test.classes.dir}" excludes="" includes="${javac.includes}" sourcepath="${test.src.dir}" srcdir="${test.src.dir}"/>
+        <copy todir="${build.test.classes.dir}">
+            <fileset dir="${test.src.dir}" excludes="${build.classes.excludes},${excludes}" includes="${includes}"/>
+        </copy>
     </target>
     <target name="-post-compile-test-single">
         <!-- Empty placeholder for easier customization. -->

Modified: trunk/abcl/nbproject/genfiles.properties
==============================================================================
--- trunk/abcl/nbproject/genfiles.properties	(original)
+++ trunk/abcl/nbproject/genfiles.properties	Sun Jan  4 12:33:37 2009
@@ -3,8 +3,8 @@
 build.xml.stylesheet.CRC32=be360661
 # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml.
 # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you.
-nbproject/build-impl.xml.data.CRC32=71623fcd
-nbproject/build-impl.xml.script.CRC32=7d8238bd
+nbproject/build-impl.xml.data.CRC32=742204ce
+nbproject/build-impl.xml.script.CRC32=b94c76f8
 nbproject/build-impl.xml.stylesheet.CRC32=e55b27f5
 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd
 nbproject/profiler-build-impl.xml.script.CRC32=abda56ed

Modified: trunk/abcl/nbproject/project.properties
==============================================================================
--- trunk/abcl/nbproject/project.properties	(original)
+++ trunk/abcl/nbproject/project.properties	Sun Jan  4 12:33:37 2009
@@ -66,3 +66,4 @@
 src.dir=${file.reference.abcl-src}
 src.doc.dir=doc
 src.themes.dir=themes
+test.src.dir=test/src

Modified: trunk/abcl/nbproject/project.xml
==============================================================================
--- trunk/abcl/nbproject/project.xml	(original)
+++ trunk/abcl/nbproject/project.xml	Sun Jan  4 12:33:37 2009
@@ -8,7 +8,9 @@
             <source-roots>
                 <root id="src.dir"/>
             </source-roots>
-            <test-roots/>
+            <test-roots>
+                <root id="test.src.dir" name="test/src"/>
+            </test-roots>
         </data>
     </configuration>
 </project>



From ehuelsmann at common-lisp.net  Sun Jan  4 14:27:56 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 04 Jan 2009 14:27:56 +0000
Subject: [armedbear-cvs] r11539 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJTxL-0008DM-V0@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan  4 14:27:54 2009
New Revision: 11539

Log:
Empty statements cleanup:

 * Remove unintentional empty statements
 * Replace empty statements with empty blocks if necessary
 * Leave empty statements which need fixing

Note: Removes orange blocks from the right margin in NetBeans.


Modified:
   trunk/abcl/src/org/armedbear/lisp/CellError.java
   trunk/abcl/src/org/armedbear/lisp/LispCharacter.java
   trunk/abcl/src/org/armedbear/lisp/LispThread.java
   trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java
   trunk/abcl/src/org/armedbear/lisp/Pathname.java
   trunk/abcl/src/org/armedbear/lisp/Primitives.java
   trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java
   trunk/abcl/src/org/armedbear/lisp/Stream.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java

Modified: trunk/abcl/src/org/armedbear/lisp/CellError.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/CellError.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/CellError.java	Sun Jan  4 14:27:54 2009
@@ -55,7 +55,7 @@
             LispObject first = initArgs.car();
             initArgs = initArgs.cdr();
             if (first == Keyword.NAME) {
-                name = initArgs.car();;
+                name = initArgs.car();
                 break;
             }
             initArgs = initArgs.cdr();

Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java	Sun Jan  4 14:27:54 2009
@@ -367,7 +367,7 @@
           }
         catch (ClassCastException e)
           {
-            ; // SBCL signals a type-error here: "not of type (UNSIGNED-BYTE 8)"
+              // SBCL signals a type-error here: "not of type (UNSIGNED-BYTE 8)"
           }
         return NIL;
       }

Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispThread.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispThread.java	Sun Jan  4 14:27:54 2009
@@ -108,7 +108,7 @@
                     funcall(fun, new LispObject[0], LispThread.this);
                 }
                 catch (ThreadDestroyed ignored) {
-                    ; // Might happen.
+                      // Might happen.
                 }
                 catch (Throwable t) {
                     if (isInterrupted()) {

Modified: trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java	Sun Jan  4 14:27:54 2009
@@ -205,9 +205,8 @@
         if (directory != NIL) {
             LispObject temp = directory;
             LispObject part = temp.car();
-            if (part == Keyword.ABSOLUTE)
-                ;
-            else if (part == Keyword.RELATIVE)
+            if (part == Keyword.ABSOLUTE) {
+            } else if (part == Keyword.RELATIVE)
                 sb.append(';');
             else
                 error(new FileError("Unsupported directory component " + part.writeToString() + ".",

Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java	Sun Jan  4 14:27:54 2009
@@ -308,11 +308,9 @@
             else
               sb.append(File.separatorChar);
         }
-        if (device == NIL)
-            ;
-        else if (device == Keyword.UNSPECIFIC)
-            ;
-        else if (device instanceof AbstractString) {
+        if (device == NIL) {
+        } else if (device == Keyword.UNSPECIFIC) {
+        } else if (device instanceof AbstractString) {
             sb.append(device.getStringValue());
             if (this instanceof LogicalPathname
                 || host == NIL)
@@ -387,8 +385,8 @@
                     // #p"./"
                     sb.append('.');
                     sb.append(separatorChar);
-                } else
-                    ; // Nothing to do.
+                }
+                // else: Nothing to do.
             } else {
                 error(new FileError("Unsupported directory component " +
                                     part.writeToString() + ".",
@@ -855,7 +853,7 @@
             } else if (key == Keyword.DEFAULTS) {
                 defaults = coerceToPathname(value);
             } else if (key == Keyword.CASE) {
-                ; // Ignored.
+                  // Ignored.
             }
         }
         if (defaults != null) {

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Sun Jan  4 14:27:54 2009
@@ -3329,9 +3329,9 @@
             while (list != NIL)
               {
                 LispObject obj = list.car();
-                if (obj instanceof Package)
-                  ; // OK.
-                else
+                if (obj instanceof Package) {
+                  // OK.
+                } else
                   {
                     String s = javaString(obj);
                     Package p = Packages.findPackage(s);

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java	Sun Jan  4 14:27:54 2009
@@ -54,9 +54,8 @@
         this(s.length());
         for (int i = capacity; i-- > 0;) {
             char c = s.charAt(i);
-            if (c == '0')
-                ;
-            else if (c == '1')
+            if (c == '0') {
+            } else if (c == '1')
                 setBit(i);
             else
                 Debug.assertTrue(false);

Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Stream.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Stream.java	Sun Jan  4 14:27:54 2009
@@ -295,8 +295,7 @@
           else if (eol == keywordCRLF)
               eolStyle = EolStyle.CRLF;
           else if (eol != keywordRAW)
-              //###FIXME: raise an error
-              ;
+              ; //###FIXME: raise an error
           
       } else
         enc = format;
@@ -314,8 +313,7 @@
       else if (enc instanceof Symbol)
           encoding = ((Symbol)enc).getName();
       else
-          //###FIXME: raise an error!
-          ;
+          ; //###FIXME: raise an error!
       
       if (encIsCp)
           encoding = "Cp" + encoding;

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Sun Jan  4 14:27:54 2009
@@ -467,8 +467,7 @@
     String symbolName = escapeSymbolName ? multipleEscape(n) : n;
     if (!escapeSymbolName)
       {
-        if (readtableCase == Keyword.PRESERVE)
-          ;
+        if (readtableCase == Keyword.PRESERVE) { }
         else if (readtableCase == Keyword.INVERT)
           symbolName = invert(symbolName);
         else if (printCase == Keyword.DOWNCASE)



From vvoutilainen at common-lisp.net  Sun Jan  4 16:44:21 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sun, 04 Jan 2009 16:44:21 +0000
Subject: [armedbear-cvs] r11540 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJW5N-00084k-Sg@common-lisp.net>

Author: vvoutilainen
Date: Sun Jan  4 16:44:21 2009
New Revision: 11540

Log:
Helper macro for defining inlining functions.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan  4 16:44:21 2009
@@ -2121,6 +2121,7 @@
         (setf (gethash string ht) g)))
     g))
 
+     
 (defknown compile-constant (t t t) t)
 (defun compile-constant (form target representation)
   (unless target
@@ -2272,11 +2273,20 @@
   (setf (gethash name *predicates*) (cons boxed-method-name unboxed-method-name))
   (install-p2-handler name 'p2-predicate))
 
+(defmacro define-inlined-function (name params preamble-and-test &body body)
+  (let* ((test (second preamble-and-test))
+	 (preamble (and test (first preamble-and-test)))
+	 (test (or test (first preamble-and-test))))
+    `(defun ,name ,params
+       ,preamble
+       (unless ,test
+	 (compile-function-call , at params)
+	 (return-from ,name))
+       , at body)))
+
 (defknown p2-predicate (t t t) t)
-(defun p2-predicate (form target representation)
-  (unless (= (length form) 2)
-    (compile-function-call form target representation)
-    (return-from p2-predicate))
+(define-inlined-function p2-predicate (form target representation)
+  ((= (length form) 2))
   (let* ((op (car form))
          (info (gethash op *predicates*))
          (boxed-method-name (car info))
@@ -2400,11 +2410,9 @@
            (emit 'i2l)))))
 
 (defknown p2-eq/neq (t t t) t)
-(defun p2-eq/neq (form target representation)
-  (aver (or (null representation) (eq representation :boolean)))
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-eq/neq))
+(define-inlined-function p2-eq/neq (form target representation)
+  ((aver (or (null representation) (eq representation :boolean)))
+   (check-arg-count form 2))
   (let* ((op (%car form))
          (args (%cdr form))
          (arg1 (%car args))
@@ -2437,11 +2445,9 @@
        (label label2)))))
 
 (defknown p2-eql (t t t) t)
-(defun p2-eql (form target representation)
-  (aver (or (null representation) (eq representation :boolean)))
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-eql))
+(define-inlined-function p2-eql (form target representation)
+  ((aver (or (null representation) (eq representation :boolean)))
+   (check-arg-count form 2))
   (let* ((arg1 (%cadr form))
          (arg2 (%caddr form))
          (type1 (derive-compiler-type arg1))
@@ -2489,11 +2495,8 @@
     (emit-move-from-stack target representation)))
 
 (defknown p2-memq (t t t) t)
-(defun p2-memq (form target representation)
-;;   (format t "p2-memq representation = ~S~%" representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-memq))
+(define-inlined-function p2-memq (form target representation)
+  ((check-arg-count form 2))
   (cond ((eq representation :boolean)
          (let* ((args (cdr form))
                 (arg1 (first args))
@@ -2507,10 +2510,8 @@
          (compile-function-call form target representation))))
 
 (defknown p2-memql (t t t) t)
-(defun p2-memql (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-memql))
+(define-inlined-function p2-memql (form target representation)
+  ((check-arg-count form 2))
   (cond ((eq representation :boolean)
          (let* ((args (cdr form))
                 (arg1 (first args))
@@ -4356,11 +4357,9 @@
       (emit-move-from-stack target))))
 
 (defknown p2-atom (t t t) t)
-(defun p2-atom (form target representation)
-  (aver (or (null representation) (eq representation :boolean)))
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-atom))
+(define-inlined-function p2-atom (form target representation)
+  ((aver (or (null representation) (eq representation :boolean)))
+   (check-arg-count form 1))
   (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil)
   (emit 'instanceof +lisp-cons-class+)
   (let ((LABEL1 (gensym))
@@ -4438,10 +4437,8 @@
 (defun p2-vectorp (form target representation)
   (p2-instanceof-predicate form target representation +lisp-abstract-vector-class+))
 
-(defun p2-coerce-to-function (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-coerce-to-function))
+(define-inlined-function p2-coerce-to-function (form target representation)
+  ((check-arg-count form 1))
   (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil)
   (emit-invokestatic +lisp-class+ "coerceToFunction"
                      (lisp-object-arg-types 1) +lisp-object+)
@@ -4566,10 +4563,8 @@
   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
   (emit-invoke-method field target representation))
 
-(defun p2-car (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-car))
+(define-inlined-function p2-car (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (%cadr form)))
     (cond ((and (null target) (< *safety* 3))
            (compile-form arg target nil))
@@ -4579,17 +4574,13 @@
           (t
 	   (emit-car/cdr arg target representation "car")))))
 
-(defun p2-cdr (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-cdr))
+(define-inlined-function p2-cdr (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (%cadr form)))
     (emit-car/cdr arg target representation "cdr")))
 
-(defun p2-cons (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-cons))
+(define-inlined-function p2-cons (form target representation)
+  ((check-arg-count form 2))
   (emit 'new +lisp-cons-class+)
   (emit 'dup)
   (let* ((args (%cdr form))
@@ -4687,10 +4678,8 @@
           (t
            (compiler-unsupported "COMPILE-QUOTE: unsupported case: ~S" form)))))
 
-(defun p2-rplacd (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-rplacd))
+(define-inlined-function p2-rplacd (form target representation)
+  ((check-arg-count form 2))
   (let ((args (cdr form)))
     (compile-form (first args) 'stack nil)
     (when target
@@ -4704,10 +4693,8 @@
       (fix-boxing representation nil)
       (emit-move-from-stack target representation))))
 
-(defun p2-set-car/cdr (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-set-car/cdr))
+(define-inlined-function p2-set-car/cdr (form target representation)
+  ((check-arg-count form 2))
   (let ((op (%car form))
         (args (%cdr form)))
     (compile-form (%car args) 'stack nil)
@@ -4988,10 +4975,8 @@
      (emit-invokespecial-init +lisp-fixnum-class+ '("I")))))
 
 (defknown p2-ash (t t t) t)
-(defun p2-ash (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-ash))
+(define-inlined-function p2-ash (form target representation)
+  ((check-arg-count form 2))
   (let* ((args (%cdr form))
          (arg1 (%car args))
          (arg2 (%cadr args))
@@ -5328,10 +5313,8 @@
          (p2-logxor new-form target representation))))))
 
 (defknown p2-lognot (t t t) t)
-(defun p2-lognot (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-lognot))
+(define-inlined-function p2-lognot (form target representation)
+  ((check-arg-count form 1))
   (cond ((and (fixnum-type-p (derive-compiler-type form)))
          (let ((arg (%cadr form)))
 	   (new-fixnum (null representation))
@@ -5349,11 +5332,8 @@
 
 ;; %ldb size position integer => byte
 (defknown p2-%ldb (t t t) t)
-(defun p2-%ldb (form target representation)
-;;   (format t "~&p2-%ldb~%")
-  (unless (check-arg-count form 3)
-    (compile-function-call form target representation)
-    (return-from p2-%ldb))
+(define-inlined-function p2-%ldb (form target representation)
+  ((check-arg-count form 3))
   (let* ((args (cdr form))
          (size-arg (%car args))
          (position-arg (%cadr args))
@@ -5422,10 +5402,8 @@
            (compile-function-call form target representation)))))
 
 (defknown p2-mod (t t t) t)
-(defun p2-mod (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-mod))
+(define-inlined-function p2-mod (form target representation)
+  ((check-arg-count form 2))
   (let* ((args (cdr form))
          (arg1 (%car args))
          (arg2 (%cadr args))
@@ -5483,11 +5461,9 @@
 ;;     (emit-move-from-stack target representation)))
 
 (defknown p2-zerop (t t t) t)
-(defun p2-zerop (form target representation)
-  (aver (or (null representation) (eq representation :boolean)))
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-zerop))
+(define-inlined-function p2-zerop (form target representation)
+  ((aver (or (null representation) (eq representation :boolean)))
+   (check-arg-count form 1))
   (let* ((arg (cadr form))
          (type (derive-compiler-type arg)))
     (cond ((fixnum-type-p type)
@@ -5585,10 +5561,8 @@
        (compile-function-call form target representation)))))
 
 (defknown p2-std-slot-value (t t t) t)
-(defun p2-std-slot-value (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-std-slot-value))
+(define-inlined-function p2-std-slot-value (form target representation)
+  ((check-arg-count form 2))
   (let* ((args (cdr form))
          (arg1 (first args))
          (arg2 (second args)))
@@ -5601,10 +5575,8 @@
 
 ;; set-std-slot-value instance slot-name new-value => new-value
 (defknown p2-set-std-slot-value (t t t) t)
-(defun p2-set-std-slot-value (form target representation)
-  (unless (check-arg-count form 3)
-    (compile-function-call form target representation)
-    (return-from p2-set-std-slot-value))
+(define-inlined-function p2-set-std-slot-value (form target representation)
+  ((check-arg-count form 3))
   (let* ((args (cdr form))
          (arg1 (first args))
          (arg2 (second args))
@@ -5641,14 +5613,12 @@
          (compile-function-call form target representation))))
 
 ;; make-sequence result-type size &key initial-element => sequence
-(defun p2-make-sequence (form target representation)
+(define-inlined-function p2-make-sequence (form target representation)
   ;; In safe code, we want to make sure the requested length does not exceed
   ;; ARRAY-DIMENSION-LIMIT.
-  (unless (and (< *safety* 3)
+  ((and (< *safety* 3)
                (= (length form) 3)
-               (null representation))
-    (compile-function-call form target representation)
-    (return-from p2-make-sequence))
+               (null representation)))
   (let* ((args (cdr form))
          (arg1 (first args))
          (arg2 (second args)))
@@ -5734,10 +5704,8 @@
          (compile-function-call form target representation))))
 
 (defknown p2-stream-element-type (t t t) t)
-(defun p2-stream-element-type (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-stream-element-type))
+(define-inlined-function p2-stream-element-type (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (%cadr form)))
     (cond ((eq (derive-compiler-type arg) 'STREAM)
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
@@ -5750,10 +5718,8 @@
 
 ;; write-8-bits byte stream => nil
 (defknown p2-write-8-bits (t t t) t)
-(defun p2-write-8-bits (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-write-8-bits))
+(define-inlined-function p2-write-8-bits (form target representation)
+  ((check-arg-count form 2))
   (let* ((arg1 (%cadr form))
          (arg2 (%caddr form))
          (type1 (derive-compiler-type arg1))
@@ -6325,10 +6291,8 @@
                (setf (car form) (if (eq test 'eq) 'delete-eq 'delete-eql)))))))
   (compile-function-call form target representation))
 
-(defun p2-length (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-length))
+(define-inlined-function p2-length (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (cadr form)))
     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     (case representation
@@ -6443,10 +6407,8 @@
           (t
            (compile-function-call form target representation)))))
 
-(defun compile-nth (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from compile-nth))
+(define-inlined-function compile-nth (form target representation)
+  ((check-arg-count form 2))
   (let ((index-form (second form))
         (list-form (third form)))
     (compile-forms-and-maybe-emit-clear-values index-form 'stack :int
@@ -6783,10 +6745,8 @@
 
 ;; char/schar string index => character
 (defknown p2-char/schar (t t t) t)
-(defun p2-char/schar (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-char/schar))
+(define-inlined-function p2-char/schar (form target representation)
+  ((check-arg-count form 2))
   (let* ((op (%car form))
          (args (%cdr form))
          (arg1 (%car args))
@@ -6827,11 +6787,8 @@
 
 ;; set-char/schar string index character => character
 (defknown p2-set-char/schar (t t t) t)
-(defun p2-set-char/schar (form target representation)
-;;   (format t "p2-set-char/schar~%")
-  (unless (check-arg-count form 3)
-    (compile-function-call form target representation)
-    (return-from p2-set-char/schar))
+(define-inlined-function p2-set-char/schar (form target representation)
+  ((check-arg-count form 3))
   (let* ((op (%car form))
          (args (%cdr form))
          (arg1 (first args))
@@ -7054,10 +7011,8 @@
          (compile-function-call form target representation))))
 
 (defknown p2-structure-ref (t t t) t)
-(defun p2-structure-ref (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-structure-ref))
+(define-inlined-function p2-structure-ref (form target representation)
+  ((check-arg-count form 2))
   (let* ((args (cdr form))
          (arg1 (first args))
          (arg2 (second args)))
@@ -7109,10 +7064,8 @@
            (compile-function-call form target representation)))))
 
 (defknown p2-structure-set (t t t) t)
-(defun p2-structure-set (form target representation)
-  (unless (check-arg-count form 3)
-    (compile-function-call form target representation)
-    (return-from p2-structure-set))
+(define-inlined-function p2-structure-set (form target representation)
+  ((check-arg-count form 3))
   (let* ((args (cdr form))
          (arg1 (first args))
          (arg2 (second args))
@@ -7153,11 +7106,9 @@
           (compile-function-call form target representation)))))
 
 
-(defun p2-not/null (form target representation)
-  (aver (or (null representation) (eq representation :boolean)))
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-not/null))
+(define-inlined-function p2-not/null (form target representation)
+  ((aver (or (null representation) (eq representation :boolean)))
+   (check-arg-count form 1))
   (let ((arg (second form)))
     (cond ((null arg)
            (emit-push-true representation))
@@ -7202,10 +7153,8 @@
              (label LABEL2)))))
   (emit-move-from-stack target representation))
 
-(defun p2-nthcdr (form target representation)
-  (unless (check-arg-count form 2)
-    (compile-function-call form target representation)
-    (return-from p2-nthcdr))
+(define-inlined-function p2-nthcdr (form target representation)
+  ((check-arg-count form 2))
   (let* ((args (%cdr form))
          (arg1 (%car args))
          (arg2 (%cadr args)))
@@ -7669,10 +7618,8 @@
          (compile-function-call form target representation))))
 
 (defknown p2-symbol-name (t t t) t)
-(defun p2-symbol-name (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-symbol-name))
+(define-inlined-function p2-symbol-name (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (%cadr form)))
     (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
@@ -7683,10 +7630,8 @@
            (compile-function-call form target representation)))))
 
 (defknown p2-symbol-package (t t t) t)
-(defun p2-symbol-package (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-symbol-package))
+(define-inlined-function p2-symbol-package (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (%cadr form)))
     (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
@@ -7774,10 +7719,8 @@
   (compile-form (third form) target representation))
 
 (defknown p2-char-code (t t t) t)
-(defun p2-char-code (form target representation)
-  (unless (check-arg-count form 1)
-    (compile-function-call form target representation)
-    (return-from p2-char-code))
+(define-inlined-function p2-char-code (form target representation)
+  ((check-arg-count form 1))
   (let ((arg (second form)))
     (cond ((characterp arg)
            (compile-constant (char-code arg) target representation))
@@ -7791,33 +7734,27 @@
            (compile-function-call form target representation)))))
 
 (defknown p2-java-jclass (t t t) t)
-(defun p2-java-jclass (form target representation)
-  (unless (and (= 2 (length form))
-               (stringp (cadr form)))
-    (compile-function-call form target representation)
-    (return-from p2-java-jclass))
+(define-inlined-function p2-java-jclass (form target representation)
+  ((and (= 2 (length form))
+	(stringp (cadr form))))
   (let ((c (ignore-errors (java:jclass (cadr form)))))
     (if c (compile-constant c target representation)
       ;; delay resolving the method to run-time; it's unavailable now
       (compile-function-call form target representation))))
 
 (defknown p2-java-jconstructor (t t t) t)
-(defun p2-java-jconstructor (form target representation)
-  (unless (and (< 1 (length form))
-               (every #'stringp (cdr form)))
-    (compile-function-call form target representation)
-    (return-from p2-java-jconstructor))
+(define-inlined-function p2-java-jconstructor (form target representation)
+  ((and (< 1 (length form))
+	(every #'stringp (cdr form))))
   (let ((c (ignore-errors (apply #'java:jconstructor (cdr form)))))
     (if c (compile-constant c target representation)
       ;; delay resolving the method to run-time; it's unavailable now
       (compile-function-call form target representation))))
 
 (defknown p2-java-jmethod (t t t) t)
-(defun p2-java-jmethod (form target representation)
-  (unless (and (< 1 (length form))
-               (every #'stringp (cdr form)))
-    (compile-function-call form target representation)
-    (return-from p2-java-jmethod))
+(define-inlined-function p2-java-jmethod (form target representation)
+  ((and (< 1 (length form))
+	(every #'stringp (cdr form))))
   (let ((m (ignore-errors (apply #'java:jmethod (cdr form)))))
     (if m (compile-constant m target representation)
       ;; delay resolving the method to run-time; it's unavailable now



From vvoutilainen at common-lisp.net  Sun Jan  4 17:29:01 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sun, 04 Jan 2009 17:29:01 +0000
Subject: [armedbear-cvs] r11541 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJWmb-00026d-6u@common-lisp.net>

Author: vvoutilainen
Date: Sun Jan  4 17:29:00 2009
New Revision: 11541

Log:
Look, I can do conditionals in the middle of a
backquote-form! :) Seriously, this commit removes
a tiny bit of copy-paste from define-resolver.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan  4 17:29:00 2009
@@ -931,16 +931,13 @@
 
 (defmacro define-resolver (opcodes args &body body)
   (let ((name (gensym)))
-    (if (listp opcodes)
-        `(progn
-           (defun ,name ,args , at body)
-           (eval-when (:load-toplevel :execute)
-             (dolist (op ',opcodes)
-               (setf (gethash op +resolvers+) (symbol-function ',name)))))
-        `(progn
-           (defun ,name ,args , at body)
-           (eval-when (:load-toplevel :execute)
-             (setf (gethash ,opcodes +resolvers+) (symbol-function ',name)))))))
+    `(progn
+       (defun ,name ,args , at body)
+       (eval-when (:load-toplevel :execute)
+	 ,(if (listp opcodes)
+	      `(dolist (op ',opcodes)
+		 (setf (gethash op +resolvers+) (symbol-function ',name)))
+	      `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name)))))))
 
 ;; aload
 (define-resolver 25 (instruction)



From vvoutilainen at common-lisp.net  Sun Jan  4 20:04:18 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sun, 04 Jan 2009 20:04:18 +0000
Subject: [armedbear-cvs] r11542 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJZCs-0002Gy-FO@common-lisp.net>

Author: vvoutilainen
Date: Sun Jan  4 20:04:17 2009
New Revision: 11542

Log:
Helper macro for declare-* functions that use hashtables.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan  4 20:04:17 2009
@@ -1805,127 +1805,123 @@
     (when (plusp (length output))
       output)))
 
+(defmacro declare-with-hashtable (declared-item hashtable hashtable-var
+				  item-var &body body)
+  `(let* ((,hashtable-var ,hashtable)
+	  (,item-var (gethash1 ,declared-item ,hashtable-var)))
+     (declare (type hash-table ,hashtable-var))
+     (unless ,item-var
+       , at body)
+     ,item-var))
+
+
 (defknown declare-symbol (symbol) string)
 (defun declare-symbol (symbol)
   (declare (type symbol symbol))
-  (let* ((ht *declared-symbols*)
-         (g (gethash1 symbol ht)))
-    (declare (type hash-table ht))
-    (unless g
-      (cond ((null (symbol-package symbol))
-             (setf g (if *compile-file-truename*
-                         (declare-object-as-string symbol)
-                         (declare-object symbol))))
-            (t
-             (let ((*code* *static-code*)
-                   (s (sanitize symbol)))
-               (setf g (symbol-name (gensym)))
-               (when s
-                 (setf g (concatenate 'string g "_" s)))
-               (declare-field g +lisp-symbol+)
-               (emit 'ldc (pool-string (symbol-name symbol)))
-               (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-               (emit-invokestatic +lisp-class+ "internInPackage"
-                                  (list +java-string+ +java-string+) +lisp-symbol+)
-               (emit 'putstatic *this-class* g +lisp-symbol+)
-               (setf *static-code* *code*)
-               (setf (gethash symbol ht) g)))))
-    g))
+  (declare-with-hashtable
+   symbol *declared-symbols* ht g
+   (cond ((null (symbol-package symbol))
+	  (setf g (if *compile-file-truename*
+		      (declare-object-as-string symbol)
+		      (declare-object symbol))))
+	 (t
+	  (let ((*code* *static-code*)
+		(s (sanitize symbol)))
+	    (setf g (symbol-name (gensym)))
+	    (when s
+	      (setf g (concatenate 'string g "_" s)))
+	    (declare-field g +lisp-symbol+)
+	    (emit 'ldc (pool-string (symbol-name symbol)))
+	    (emit 'ldc (pool-string (package-name (symbol-package symbol))))
+	    (emit-invokestatic +lisp-class+ "internInPackage"
+			       (list +java-string+ +java-string+) +lisp-symbol+)
+	    (emit 'putstatic *this-class* g +lisp-symbol+)
+	    (setf *static-code* *code*)
+	    (setf (gethash symbol ht) g))))))
 
 (defknown declare-keyword (symbol) string)
 (defun declare-keyword (symbol)
   (declare (type symbol symbol))
-  (let* ((ht *declared-symbols*)
-         (g (gethash1 symbol ht)))
-    (declare (type hash-table ht))
-    (unless g
-      (let ((*code* *static-code*))
-        (setf g (symbol-name (gensym)))
-        (declare-field g +lisp-symbol+)
-        (emit 'ldc (pool-string (symbol-name symbol)))
-        (emit-invokestatic +lisp-class+ "internKeyword"
-                           (list +java-string+) +lisp-symbol+)
-        (emit 'putstatic *this-class* g +lisp-symbol+)
-        (setf *static-code* *code*)
-        (setf (gethash symbol ht) g)))
-    g))
+  (declare-with-hashtable
+   symbol *declared-symbols* ht g
+   (let ((*code* *static-code*))
+     (setf g (symbol-name (gensym)))
+     (declare-field g +lisp-symbol+)
+     (emit 'ldc (pool-string (symbol-name symbol)))
+     (emit-invokestatic +lisp-class+ "internKeyword"
+			(list +java-string+) +lisp-symbol+)
+     (emit 'putstatic *this-class* g +lisp-symbol+)
+     (setf *static-code* *code*)
+     (setf (gethash symbol ht) g))))
 
 (defknown declare-function (symbol) string)
 (defun declare-function (symbol)
   (declare (type symbol symbol))
-  (let* ((ht *declared-functions*)
-         (f (gethash1 symbol ht)))
-    (declare (type hash-table ht))
-    (unless f
-      (setf f (symbol-name (gensym)))
-      (let ((s (sanitize symbol)))
-        (when s
-          (setf f (concatenate 'string f "_" s))))
-      (let ((*code* *static-code*)
-            (g (gethash1 symbol (the hash-table *declared-symbols*))))
-        (cond (g
-               (emit 'getstatic *this-class* g +lisp-symbol+))
-              (t
-               (emit 'ldc (pool-string (symbol-name symbol)))
-               (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-               (emit-invokestatic +lisp-class+ "internInPackage"
-                                  (list +java-string+ +java-string+)
-                                  +lisp-symbol+)))
-        (declare-field f +lisp-object+)
-        (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
-                            nil +lisp-object+)
-        (emit 'putstatic *this-class* f +lisp-object+)
-        (setf *static-code* *code*)
-        (setf (gethash symbol ht) f)))
-    f))
+  (declare-with-hashtable
+   symbol *declared-functions* ht f
+   (setf f (symbol-name (gensym)))
+   (let ((s (sanitize symbol)))
+     (when s
+       (setf f (concatenate 'string f "_" s))))
+   (let ((*code* *static-code*)
+	 (g (gethash1 symbol (the hash-table *declared-symbols*))))
+     (cond (g
+	    (emit 'getstatic *this-class* g +lisp-symbol+))
+	   (t
+	    (emit 'ldc (pool-string (symbol-name symbol)))
+	    (emit 'ldc (pool-string (package-name (symbol-package symbol))))
+	    (emit-invokestatic +lisp-class+ "internInPackage"
+			       (list +java-string+ +java-string+)
+			       +lisp-symbol+)))
+     (declare-field f +lisp-object+)
+     (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
+			 nil +lisp-object+)
+     (emit 'putstatic *this-class* f +lisp-object+)
+     (setf *static-code* *code*)
+     (setf (gethash symbol ht) f))))
 
 (defknown declare-setf-function (name) string)
 (defun declare-setf-function (name)
-  (let* ((ht *declared-functions*)
-         (f (gethash1 name ht)))
-    (declare (type hash-table ht))
-    (unless f
-      (let ((symbol (cadr name)))
-        (declare (type symbol symbol))
-        (setf f (symbol-name (gensym)))
-        (let ((s (sanitize symbol)))
-          (when s
-            (setf f (concatenate 'string f "_SETF_" s))))
-        (let ((*code* *static-code*)
-              (g (gethash1 symbol (the hash-table *declared-symbols*))))
-          (cond (g
-                 (emit 'getstatic *this-class* g +lisp-symbol+))
-                (t
-                 (emit 'ldc (pool-string (symbol-name symbol)))
-                 (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-                 (emit-invokestatic +lisp-class+ "internInPackage"
-                                    (list +java-string+ +java-string+)
-                                    +lisp-symbol+)))
-          (declare-field f +lisp-object+)
-          (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
-                              nil +lisp-object+)
-          (emit 'putstatic *this-class* f +lisp-object+)
-          (setf *static-code* *code*)
-          (setf (gethash name ht) f))))
-    f))
+  (declare-with-hashtable
+   name *declared-functions* ht f
+   (let ((symbol (cadr name)))
+     (declare (type symbol symbol))
+     (setf f (symbol-name (gensym)))
+     (let ((s (sanitize symbol)))
+       (when s
+	 (setf f (concatenate 'string f "_SETF_" s))))
+     (let ((*code* *static-code*)
+	   (g (gethash1 symbol (the hash-table *declared-symbols*))))
+       (cond (g
+	      (emit 'getstatic *this-class* g +lisp-symbol+))
+	     (t
+	      (emit 'ldc (pool-string (symbol-name symbol)))
+	      (emit 'ldc (pool-string (package-name (symbol-package symbol))))
+	      (emit-invokestatic +lisp-class+ "internInPackage"
+				 (list +java-string+ +java-string+)
+				 +lisp-symbol+)))
+       (declare-field f +lisp-object+)
+       (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
+			   nil +lisp-object+)
+       (emit 'putstatic *this-class* f +lisp-object+)
+       (setf *static-code* *code*)
+       (setf (gethash name ht) f)))))
+
 
 (defknown declare-local-function (local-function) string)
 (defun declare-local-function (local-function)
-  (let* ((ht *declared-functions*)
-         (g (gethash1 local-function ht)))
-    (declare (type hash-table ht))
-    (unless g
-      (setf g (symbol-name (gensym)))
-      (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
-             (*code* *static-code*))
-        (declare-field g +lisp-object+)
-        (emit 'ldc (pool-string (file-namestring pathname)))
-        (emit-invokestatic +lisp-class+ "loadCompiledFunction"
-                           (list +java-string+) +lisp-object+)
-        (emit 'putstatic *this-class* g +lisp-object+)
-        (setf *static-code* *code*)
-        (setf (gethash local-function ht) g)))
-    g))
+  (declare-with-hashtable
+   local-function *declared-functions* ht g
+   (setf g (symbol-name (gensym)))
+   (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
+	  (*code* *static-code*))
+     (declare-field g +lisp-object+)
+     (emit 'ldc (pool-string (file-namestring pathname)))
+     (emit-invokestatic +lisp-class+ "loadCompiledFunction"
+			(list +java-string+) +lisp-object+)
+     (emit 'putstatic *this-class* g +lisp-object+)
+     (setf *static-code* *code*)
+     (setf (gethash local-function ht) g))))
 
 (defun new-fixnum (&optional (test-val t))
   (when test-val
@@ -1935,61 +1931,55 @@
 (defknown declare-fixnum (fixnum) string)
 (defun declare-fixnum (n)
   (declare (type fixnum n))
-  (let* ((ht *declared-integers*)
-         (g (gethash1 n ht)))
-    (declare (type hash-table ht))
-    (unless g
-      (let ((*code* *static-code*))
-        (setf g (format nil "FIXNUM_~A~D"
-                        (if (minusp n) "MINUS_" "")
-                        (abs n)))
-        (declare-field g +lisp-fixnum+)
-        (cond ((<= 0 n 255)
-               (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
-               (emit-push-constant-int n)
-               (emit 'aaload))
-              (t
-	       (new-fixnum)
-               (emit-push-constant-int n)
-               (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
-        (emit 'putstatic *this-class* g +lisp-fixnum+)
-        (setf *static-code* *code*)
-        (setf (gethash n ht) g)))
-    g))
+  (declare-with-hashtable
+   n *declared-integers* ht g
+   (let ((*code* *static-code*))
+     (setf g (format nil "FIXNUM_~A~D"
+		     (if (minusp n) "MINUS_" "")
+		     (abs n)))
+     (declare-field g +lisp-fixnum+)
+     (cond ((<= 0 n 255)
+	    (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
+	    (emit-push-constant-int n)
+	    (emit 'aaload))
+	   (t
+	    (new-fixnum)
+	    (emit-push-constant-int n)
+	    (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+     (emit 'putstatic *this-class* g +lisp-fixnum+)
+     (setf *static-code* *code*)
+     (setf (gethash n ht) g))))
 
 (defknown declare-bignum (integer) string)
 (defun declare-bignum (n)
-  (let* ((ht *declared-integers*)
-         (g (gethash1 n ht)))
-    (declare (type hash-table ht))
-    (unless g
-      (cond ((<= most-negative-java-long n most-positive-java-long)
-             (let ((*code* *static-code*))
-               (setf g (format nil "BIGNUM_~A~D"
-                               (if (minusp n) "MINUS_" "")
-                               (abs n)))
-               (declare-field g +lisp-bignum+)
-               (emit 'new +lisp-bignum-class+)
-               (emit 'dup)
-               (emit 'ldc2_w (pool-long n))
-               (emit-invokespecial-init +lisp-bignum-class+ '("J"))
-               (emit 'putstatic *this-class* g +lisp-bignum+)
-               (setf *static-code* *code*)))
-            (t
-             (let* ((*print-base* 10)
-                    (s (with-output-to-string (stream) (dump-form n stream)))
-                    (*code* *static-code*))
-               (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
-               (declare-field g +lisp-bignum+)
-               (emit 'new +lisp-bignum-class+)
-               (emit 'dup)
-               (emit 'ldc (pool-string s))
-               (emit-push-constant-int 10)
-               (emit-invokespecial-init +lisp-bignum-class+ (list +java-string+ "I"))
-               (emit 'putstatic *this-class* g +lisp-bignum+)
-               (setf *static-code* *code*))))
-      (setf (gethash n ht) g))
-    g))
+  (declare-with-hashtable
+   n *declared-integers* ht g
+   (cond ((<= most-negative-java-long n most-positive-java-long)
+	  (let ((*code* *static-code*))
+	    (setf g (format nil "BIGNUM_~A~D"
+			    (if (minusp n) "MINUS_" "")
+			    (abs n)))
+	    (declare-field g +lisp-bignum+)
+	    (emit 'new +lisp-bignum-class+)
+	    (emit 'dup)
+	    (emit 'ldc2_w (pool-long n))
+	    (emit-invokespecial-init +lisp-bignum-class+ '("J"))
+	    (emit 'putstatic *this-class* g +lisp-bignum+)
+	    (setf *static-code* *code*)))
+	 (t
+	  (let* ((*print-base* 10)
+		 (s (with-output-to-string (stream) (dump-form n stream)))
+		 (*code* *static-code*))
+	    (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
+	    (declare-field g +lisp-bignum+)
+	    (emit 'new +lisp-bignum-class+)
+	    (emit 'dup)
+	    (emit 'ldc (pool-string s))
+	    (emit-push-constant-int 10)
+	    (emit-invokespecial-init +lisp-bignum-class+ (list +java-string+ "I"))
+	    (emit 'putstatic *this-class* g +lisp-bignum+)
+	    (setf *static-code* *code*))))
+   (setf (gethash n ht) g)))
 
 (defknown declare-character (t) string)
 (defun declare-character (c)
@@ -2102,11 +2092,9 @@
     g))
 
 (defun declare-string (string)
-  (let* ((ht *declared-strings*)
-         (g (gethash1 string ht)))
-    (declare (type hash-table ht))
-    (unless g
-      (let ((*code* *static-code*))
+  (declare-with-hashtable
+   string *declared-strings* ht g
+   (let ((*code* *static-code*))
         (setf g (symbol-name (gensym)))
         (declare-field g +lisp-simple-string+)
         (emit 'new +lisp-simple-string-class+)
@@ -2115,9 +2103,7 @@
         (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
         (emit 'putstatic *this-class* g +lisp-simple-string+)
         (setf *static-code* *code*)
-        (setf (gethash string ht) g)))
-    g))
-
+        (setf (gethash string ht) g))))
      
 (defknown compile-constant (t t t) t)
 (defun compile-constant (form target representation)



From vvoutilainen at common-lisp.net  Sun Jan  4 22:03:42 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sun, 04 Jan 2009 22:03:42 +0000
Subject: [armedbear-cvs] r11543 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJb4Q-0000VR-5E@common-lisp.net>

Author: vvoutilainen
Date: Sun Jan  4 22:03:41 2009
New Revision: 11543

Log:
Little helper for p2-plus/minus/times.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan  4 22:03:41 2009
@@ -6401,6 +6401,15 @@
     (fix-boxing representation nil) ; FIXME use derived result type
     (emit-move-from-stack target representation)))
 
+(defun two-long-ints-times/plus/minus (arg1 arg2 instruction representation)
+  (compile-form arg1 'stack :int)
+  (emit 'i2l)
+  (compile-form arg2 'stack :int)
+  (emit 'i2l)
+  (maybe-emit-clear-values arg1 arg2)
+  (emit instruction)
+  (convert-long representation))
+
 (defun p2-times (form target representation)
   (case (length form)
     (3
@@ -6429,17 +6438,11 @@
                      (emit 'imul)
                      (unless (eq representation :int)
                        (emit-invokespecial-init +lisp-fixnum-class+ '("I"))
-                       (fix-boxing representation 'fixnum))
-                     (emit-move-from-stack target representation))
+                       (fix-boxing representation 'fixnum)))
                     (t
-                     (compile-form arg1 'stack :int)
-                     (emit 'i2l)
-                     (compile-form arg2 'stack :int)
-                     (emit 'i2l)
-                     (maybe-emit-clear-values arg1 arg2)
-                     (emit 'lmul)
-                     (convert-long representation)
-                     (emit-move-from-stack target representation))))
+		     (two-long-ints-times/plus/minus 
+		      arg1 arg2 'lmul representation)))
+	      (emit-move-from-stack target representation))
              ((and (java-long-type-p type1)
                    (java-long-type-p type2)
                    (java-long-type-p result-type))
@@ -6585,13 +6588,8 @@
                      (emit 'iadd)
 		     (emit-fixnum-init representation))
                     (t
-                     (compile-form arg1 'stack :int)
-                     (emit 'i2l)
-                     (compile-form arg2 'stack :int)
-                     (emit 'i2l)
-                     (maybe-emit-clear-values arg1 arg2)
-                     (emit 'ladd)
-                     (convert-long representation)))
+		     (two-long-ints-times/plus/minus 
+		      arg1 arg2 'ladd representation)))
               (emit-move-from-stack target representation))
              ((and (java-long-type-p type1)
                    (java-long-type-p type2)
@@ -6696,13 +6694,8 @@
                      (emit 'isub)
 		     (emit-fixnum-init representation))
                     (t
-                     (compile-form arg1 'stack :int)
-                     (emit 'i2l)
-                     (compile-form arg2 'stack :int)
-                     (emit 'i2l)
-                     (maybe-emit-clear-values arg1 arg2)
-                     (emit 'lsub)
-                     (convert-long representation)))
+		     (two-long-ints-times/plus/minus 
+		      arg1 arg2 'lsub representation)))
               (emit-move-from-stack target representation))
              ((and (java-long-type-p type1) (java-long-type-p type2)
                    (java-long-type-p result-type))



From ehuelsmann at common-lisp.net  Sun Jan  4 22:16:29 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 04 Jan 2009 22:16:29 +0000
Subject: [armedbear-cvs] r11544 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJbGn-0000me-UQ@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan  4 22:16:29 2009
New Revision: 11544

Log:
Add bounds checking and prepare for support for 'wide' instruction prefix.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan  4 22:16:29 2009
@@ -156,9 +156,31 @@
 (defun u2 (n)
   (declare (optimize speed))
   (declare (type (unsigned-byte 16) n))
+  (when (not (<= 0 n 65535))
+    (error "u2 argument ~A out of 65k range." n))
   (list (logand (ash n -8) #xff)
         (logand n #xff)))
 
+(defknown s1 (fixnum) fixnum)
+(defun s1 (n)
+  (declare (optimize speed))
+  (declare (type (signed-byte 8) n))
+  (when (not (<= -128 n 127))
+    (error "s2 argument ~A out of 16-bit signed range." n))
+  (if (< n 0)
+      (1+ (logxor (- n) #xFF))
+      n))
+
+
+(defknown s2 (fixnum) cons)
+(defun s2 (n)
+  (declare (optimize speed))
+  (declare (type (signed-byte 16) n))
+  (when (not (<= -32768 n 32767))
+    (error "s2 argument ~A out of 16-bit signed range." n))
+  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
+          n)))
+
 (defconstant +java-string+ "Ljava/lang/String;")
 (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
 (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass")
@@ -201,11 +223,20 @@
 (defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable")
 (defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream")
 
-(defstruct (instruction (:constructor make-instruction (opcode args)))
+(defstruct (instruction (:constructor %make-instruction (opcode args)))
   (opcode 0 :type (integer 0 255))
   args
   stack
-  depth)
+  depth
+  wide)
+
+(defun make-instruction (opcode args)
+  (let ((inst (apply #'%make-instruction
+                     (list opcode
+                           (remove :wide-prefix args)))))
+    (when (memq :wide-prefix args)
+      (setf (inst-wide inst) t))
+    inst))
 
 (defun print-instruction (instruction)
   (sys::%format nil "~A ~A stack = ~S depth = ~S"
@@ -1027,7 +1058,7 @@
           ((<= -128 n 127)
            (inst 16 (logand n #xff))) ; BIPUSH
           (t ; SIPUSH
-           (inst 17 (u2 n))))))
+           (inst 17 (s2 n))))))
 
 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
 (define-resolver (182 183 184) (instruction)
@@ -1074,7 +1105,9 @@
   (let* ((args (instruction-args instruction))
          (register (first args))
          (n (second args)))
-    (inst 132 (list register (logand n #xff)))))
+    (when (not (<= -128 n 127))
+      (error "IINC argument ~A out of bounds." n))
+    (inst 132 (list register (s1 n)))))
 
 (defknown resolve-instruction (t) t)
 (defun resolve-instruction (instruction)
@@ -1490,7 +1523,7 @@
           (when (branch-opcode-p (instruction-opcode instruction))
             (let* ((label (car (instruction-args instruction)))
                    (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
-              (setf (instruction-args instruction) (u2 offset))))
+              (setf (instruction-args instruction) (s2 offset))))
           (unless (= (instruction-opcode instruction) 202) ; LABEL
             (incf index (opcode-size (instruction-opcode instruction)))))))
     ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.



From vvoutilainen at common-lisp.net  Sun Jan  4 22:21:07 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sun, 04 Jan 2009 22:21:07 +0000
Subject: [armedbear-cvs] r11545 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJbLH-0001TT-Fn@common-lisp.net>

Author: vvoutilainen
Date: Sun Jan  4 22:21:07 2009
New Revision: 11545

Log:
Another small helper for p2-plus/minus.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan  4 22:21:07 2009
@@ -6586,6 +6586,20 @@
          (t
           (compile-function-call form target representation))))
 
+(defun fixnum-result-plus/minus (target representation result-type arg1 arg2
+				 int-op long-op)
+  (cond ((or (eq representation :int)
+	     (fixnum-type-p result-type))
+	 (new-fixnum (null representation))
+	 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
+						    arg2 'stack :int)
+	 (emit int-op)
+	 (emit-fixnum-init representation))
+	(t
+	 (two-long-ints-times/plus/minus 
+	  arg1 arg2 long-op representation)))
+  (emit-move-from-stack target representation))
+
 (defun p2-plus (form target representation)
   (case (length form)
     (3
@@ -6613,17 +6627,8 @@
 							 arg2 nil nil)
               (emit-move-from-stack target representation))
              ((and (fixnum-type-p type1) (fixnum-type-p type2))
-              (cond ((or (eq representation :int)
-                         (fixnum-type-p result-type))
-		     (new-fixnum (null representation))
-		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-								arg2 'stack :int)
-                     (emit 'iadd)
-		     (emit-fixnum-init representation))
-                    (t
-		     (two-long-ints-times/plus/minus 
-		      arg1 arg2 'ladd representation)))
-              (emit-move-from-stack target representation))
+	      (fixnum-result-plus/minus target representation result-type 
+					arg1 arg2 'iadd 'ladd))
              ((and (java-long-type-p type1)
                    (java-long-type-p type2)
                    (java-long-type-p result-type))
@@ -6719,17 +6724,8 @@
        (cond ((and (numberp arg1) (numberp arg2))
               (compile-constant (- arg1 arg2) target representation))
              ((and (fixnum-type-p type1) (fixnum-type-p type2))
-              (cond ((or (eq representation :int)
-                         (fixnum-type-p result-type))
-		     (new-fixnum (null representation))
-		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-								arg2 'stack :int)
-                     (emit 'isub)
-		     (emit-fixnum-init representation))
-                    (t
-		     (two-long-ints-times/plus/minus 
-		      arg1 arg2 'lsub representation)))
-              (emit-move-from-stack target representation))
+	      (fixnum-result-plus/minus target representation result-type 
+					arg1 arg2 'isub 'lsub))
              ((and (java-long-type-p type1) (java-long-type-p type2)
                    (java-long-type-p result-type))
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack :long



From mevenson at common-lisp.net  Mon Jan  5 10:56:01 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Mon, 05 Jan 2009 10:56:01 +0000
Subject: [armedbear-cvs] r11546 - trunk/abcl
Message-ID: <E1LJn7p-00055U-N9@common-lisp.net>

Author: mevenson
Date: Mon Jan  5 10:56:01 2009
New Revision: 11546

Log:
More fixes for the Ant target 'abcl.test'.

For some odd reason, pathnames as arguments to <java> tags in Ant seem
very inconsistent.  We specify the pathname via the 'line' attribute
in <arg>, but would rather use the 'file' attribute.

The CLOS stuff in 'abcl.asd' still doesn't work correctly for unknown reasons.



Modified:
   trunk/abcl/abcl.asd   (contents, props changed)
   trunk/abcl/build.xml

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Mon Jan  5 10:56:01 2009
@@ -10,14 +10,12 @@
   :documentation "Wrapper for all ABCL ASDF definitions."
   :version "0.2.0")
 
-(defmethod perform :around ((o load-op) (c (eql (find-system 'abcl))))
-  (call-next-method)
-  (format t "DEBUG: load-op around :abcl.~%")
-  (asdf:oos 'asdf:load-op :test-abcl))
+(defmethod perform :after ((o load-op) (c (eql (find-system 'abcl))))
+  ;;; Additional test suite loads would go here.
+  (asdf:oos 'asdf:load-op :test-abcl :force t))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'abcl))))
-  (format t "DEBUG: test-op :abcl.~%")
-  (asdf:oos 'asdf:load-op :test-abcl :force t)
+  ;;; Additional test suite invocations would go here.
   (asdf:oos 'asdf:test-op :ansi-test-compiled :force t))
 
 (defsystem :test-abcl

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Mon Jan  5 10:56:01 2009
@@ -460,9 +460,9 @@
       <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
-	<arg value="--noinit"/>
+ 	<arg value="--noinit"/> 
 	<arg value="--load"/>
-	<arg value="${basedir}/scripts/ansi-tests-interpreted.lisp "/>
+	<arg line="${basedir}/scripts/ansi-tests-interpreted.lisp"/>
       </java>
     </target>
 
@@ -470,9 +470,9 @@
       <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
-	<arg value="--noinit"/>
+	<arg value="--noinit"/> 
 	<arg value="--load"/>
-	<arg value="${basedir}/scripts/ansi-tests-compiled.lisp "/>
+ 	<arg line="${basedir}/scripts/ansi-tests-compiled.lisp "/> 
       </java>
     </target>
 



From vvoutilainen at common-lisp.net  Mon Jan  5 15:26:02 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Mon, 05 Jan 2009 15:26:02 +0000
Subject: [armedbear-cvs] r11547 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJrL8-0004rI-Ah@common-lisp.net>

Author: vvoutilainen
Date: Mon Jan  5 15:26:01 2009
New Revision: 11547

Log:
For let, variable values must be bound after the let-forms.
This patch postpones the binds until all let-forms have been
evaluated, aka just before the body is evaluated.


Modified:
   trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java

Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java	Mon Jan  5 15:26:01 2009
@@ -34,7 +34,7 @@
 package org.armedbear.lisp;
 
 import java.util.ArrayList;
-
+import java.util.LinkedList;
 public final class SpecialOperators extends Lisp
 {
   // ### quote
@@ -109,6 +109,24 @@
       }
     };
 
+  private static final void bindArg(LispObject specials, Symbol symbol,
+			       LispObject value, Environment ext)
+    throws ConditionThrowable
+    {
+      final LispThread thread = LispThread.currentThread();
+      if (specials != NIL && memq(symbol, specials))
+	{
+	  thread.bindSpecial(symbol, value);
+	  ext.declareSpecial(symbol);
+	}
+      else if (symbol.isSpecialVariable())
+	{
+	  thread.bindSpecial(symbol, value);
+	}
+      else
+	  ext.bind(symbol, value);
+    }
+
   private static final LispObject _let(LispObject args, Environment env,
                                        boolean sequential)
     throws ConditionThrowable
@@ -147,6 +165,7 @@
               break;
           }
         Environment ext = new Environment(env);
+	LinkedList<Cons> nonSequentialVars = new LinkedList<Cons>();
         while (varList != NIL)
           {
             final Symbol symbol;
@@ -180,19 +199,19 @@
                   }
                 value = NIL;
               }
-            if (specials != NIL && memq(symbol, specials))
-              {
-                thread.bindSpecial(symbol, value);
-                ext.declareSpecial(symbol);
-              }
-            else if (symbol.isSpecialVariable())
-              {
-                thread.bindSpecial(symbol, value);
-              }
-            else
-              ext.bind(symbol, value);
+	    if (sequential)
+		bindArg(specials, symbol, value, ext);
+	    else
+		nonSequentialVars.add(new Cons(symbol, value));
             varList = ((Cons)varList).cdr;
           }
+	if (!sequential)
+	  {
+	    for (Cons x : nonSequentialVars)
+	      {
+		bindArg(specials, (Symbol)x.car(), x.cdr(), ext);
+	      }
+	  }
         // Make sure free special declarations are visible in the body.
         // "The scope of free declarations specifically does not include
         // initialization forms for bindings established by the form



From vvoutilainen at common-lisp.net  Tue Jan  6 12:12:15 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Tue, 06 Jan 2009 12:12:15 +0000
Subject: [armedbear-cvs] r11548 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LKAn9-00080q-Hn@common-lisp.net>

Author: vvoutilainen
Date: Tue Jan  6 12:12:14 2009
New Revision: 11548

Log:
Remove bindArg duplication.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Closure.java
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java

Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Closure.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Closure.java	Tue Jan  6 12:12:14 2009
@@ -427,7 +427,7 @@
       {
         bindParameterDefaults(optionalParameters, ext, thread);
         if (restVar != null)
-          bindArg(restVar, NIL, ext, thread);
+          bindArg(specials, restVar, NIL, ext, thread);
         bindParameterDefaults(keywordParameters, ext, thread);
       }
     bindAuxVars(ext, thread);
@@ -448,10 +448,10 @@
   {
     // &whole and &environment before anything
     if (envVar != null)
-      bindArg(envVar, environment, ext, thread);
+      bindArg(specials, envVar, environment, ext, thread);
     for (int i = 0; i < objects.length; ++i)
       {
-        bindArg(requiredParameters[i].var, objects[i], ext, thread);
+        bindArg(specials, requiredParameters[i].var, objects[i], ext, thread);
       }
   }
 
@@ -644,12 +644,12 @@
     Debug.assertTrue(args.length == variables.length);
     if (envVar != null)
       {
-        bindArg(envVar, environment, ext, thread);
+        bindArg(specials, envVar, environment, ext, thread);
       }
     for (int i = 0; i < variables.length; i++)
       {
         Symbol sym = variables[i];
-        bindArg(sym, args[i], ext, thread);
+        bindArg(specials, sym, args[i], ext, thread);
       }
     bindAuxVars(ext, thread);
     special:
@@ -672,18 +672,6 @@
       }
   }
 
-  private final boolean isSpecial(Symbol sym)
-  {
-    if (sym.isSpecialVariable())
-      return true;
-    for (Symbol special : specials)
-      {
-        if (sym == special)
-            return true;
-      }
-    return false;
-  }
-
   protected final LispObject[] processArgs(LispObject[] args, LispThread thread)
     throws ConditionThrowable
   {
@@ -711,12 +699,12 @@
     // &whole before any other variables in the lambda list..."
     if (bindInitForms)
       if (envVar != null)
-          bindArg(envVar, environment, ext, thread);
+	bindArg(specials, envVar, environment, ext, thread);
     // Required parameters.
     for (int i = 0; i < minArgs; i++)
       {
         if (bindInitForms)
-          bindArg(requiredParameters[i].var, args[i], ext, thread);
+          bindArg(specials, requiredParameters[i].var, args[i], ext, thread);
         array[index++] = args[i];
       }
     int i = minArgs;
@@ -727,13 +715,13 @@
         if (i < argsLength)
           {
             if (bindInitForms)
-              bindArg(parameter.var, args[i], ext, thread);
+              bindArg(specials, parameter.var, args[i], ext, thread);
             array[index++] = args[i];
             ++argsUsed;
             if (parameter.svar != NIL)
               {
                 if (bindInitForms)
-                  bindArg((Symbol)parameter.svar, T, ext, thread);
+                  bindArg(specials, (Symbol)parameter.svar, T, ext, thread);
                 array[index++] = T;
               }
           }
@@ -746,12 +734,12 @@
             else
               value = eval(parameter.initForm, ext, thread);
             if (bindInitForms)
-              bindArg(parameter.var, value, ext, thread);
+              bindArg(specials, parameter.var, value, ext, thread);
             array[index++] = value;
             if (parameter.svar != NIL)
               {
                 if (bindInitForms)
-                  bindArg((Symbol)parameter.svar, NIL, ext, thread);
+                  bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread);
                 array[index++] = NIL;
               }
           }
@@ -764,7 +752,7 @@
         for (int j = argsLength; j-- > argsUsed;)
           rest = new Cons(args[j], rest);
         if (bindInitForms)
-            bindArg(restVar, rest, ext, thread);
+	  bindArg(specials, restVar, rest, ext, thread);
         array[index++] = rest;
       }
     // Keyword parameters.
@@ -784,12 +772,12 @@
                 else
                   value = eval(parameter.initForm, ext, thread);
                 if (bindInitForms)
-                    bindArg(parameter.var, value, ext, thread);
+		  bindArg(specials, parameter.var, value, ext, thread);
                 array[index++] = value;
                 if (parameter.svar != NIL)
                   {
                     if (bindInitForms)
-                        bindArg((Symbol)parameter.svar, NIL, ext, thread);
+		      bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread);
                     array[index++] = NIL;
                   }
               }
@@ -809,12 +797,12 @@
                     if (args[j] == keyword)
                       {
                         if (bindInitForms)
-                            bindArg(parameter.var, args[j+1], ext, thread);
+			  bindArg(specials, parameter.var, args[j+1], ext, thread);
                         value = array[index++] = args[j+1];
                         if (parameter.svar != NIL)
                           {
                             if (bindInitForms)
-                                bindArg((Symbol)parameter.svar, T, ext, thread);
+			      bindArg(specials,(Symbol)parameter.svar, T, ext, thread);
                             array[index++] = T;
                           }
                         args[j] = null;
@@ -830,12 +818,12 @@
                     else
                       value = eval(parameter.initForm, ext, thread);
                     if (bindInitForms)
-                        bindArg(parameter.var, value, ext, thread);
+		      bindArg(specials, parameter.var, value, ext, thread);
                     array[index++] = value;
                     if (parameter.svar != NIL)
                       {
                         if (bindInitForms)
-                            bindArg((Symbol)parameter.svar, NIL, ext, thread);
+			  bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread);
                         array[index++] = NIL;
                       }
                   }
@@ -1029,24 +1017,12 @@
           value = parameter.initVal;
         else
           value = eval(parameter.initForm, env, thread);
-        bindArg(parameter.var, value, env, thread);
+        bindArg(specials, parameter.var, value, env, thread);
         if (parameter.svar != NIL)
-            bindArg((Symbol)parameter.svar, NIL, env, thread);
+	  bindArg(specials, (Symbol)parameter.svar, NIL, env, thread);
       }
   }
 
-    private final void bindArg(Symbol sym, LispObject value,
-                               Environment env, LispThread thread)
-        throws ConditionThrowable
-    {
-        if (isSpecial(sym)) {
-            env.declareSpecial(sym);
-            thread.bindSpecial(sym, value);
-        }
-        else
-            env.bind(sym, value);
-    }
-
   private final void bindAuxVars(Environment env, LispThread thread)
     throws ConditionThrowable
   {
@@ -1061,7 +1037,7 @@
         else
           value = eval(parameter.initForm, env, thread);
 
-        bindArg(sym, value, env, thread);
+        bindArg(specials, sym, value, env, thread);
       }
   }
 

Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java	Tue Jan  6 12:12:14 2009
@@ -562,14 +562,32 @@
   }
 
   // Environment wrappers.
-  public static final void bind(Symbol symbol, LispObject value,
-                                Environment env)
+  private static final boolean isSpecial(Symbol sym, Symbol[] ownSpecials,
+					 Environment env)
+  {
+    if (ownSpecials != null)
+      {
+	if (sym.isSpecialVariable())
+	  return true;
+	for (Symbol special : ownSpecials)
+	  {
+	    if (sym == special)
+	      return true;
+	  }
+      }
+    return false;
+  }
+  protected static final void bindArg(Symbol[] ownSpecials,
+				      Symbol sym, LispObject value,
+				      Environment env, LispThread thread)
     throws ConditionThrowable
   {
-    if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol))
-      LispThread.currentThread().bindSpecial(symbol, value);
+    if (isSpecial(sym, ownSpecials, env)) {
+      env.declareSpecial(sym);
+      thread.bindSpecial(sym, value);
+    }
     else
-      env.bind(symbol, value);
+      env.bind(sym, value);
   }
 
   public static final Cons list1(LispObject obj1)

Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java	Tue Jan  6 12:12:14 2009
@@ -109,24 +109,6 @@
       }
     };
 
-  private static final void bindArg(LispObject specials, Symbol symbol,
-			       LispObject value, Environment ext)
-    throws ConditionThrowable
-    {
-      final LispThread thread = LispThread.currentThread();
-      if (specials != NIL && memq(symbol, specials))
-	{
-	  thread.bindSpecial(symbol, value);
-	  ext.declareSpecial(symbol);
-	}
-      else if (symbol.isSpecialVariable())
-	{
-	  thread.bindSpecial(symbol, value);
-	}
-      else
-	  ext.bind(symbol, value);
-    }
-
   private static final LispObject _let(LispObject args, Environment env,
                                        boolean sequential)
     throws ConditionThrowable
@@ -138,7 +120,7 @@
         LispObject varList = checkList(args.car());
         LispObject body = args.cdr();
         // Process declarations.
-        LispObject specials = NIL;
+        ArrayList<Symbol> specials = new ArrayList<Symbol>();
         while (body != NIL)
           {
             LispObject obj = body.car();
@@ -153,7 +135,7 @@
                         LispObject vars = ((Cons)decl).cdr;
                         while (vars != NIL)
                           {
-                            specials = new Cons(vars.car(), specials);
+			    specials.add(0, (Symbol) vars.car());
                             vars = ((Cons)vars).cdr;
                           }
                       }
@@ -166,6 +148,7 @@
           }
         Environment ext = new Environment(env);
 	LinkedList<Cons> nonSequentialVars = new LinkedList<Cons>();
+	Symbol[] arrayToUseForSpecials = new Symbol[0];
         while (varList != NIL)
           {
             final Symbol symbol;
@@ -200,7 +183,8 @@
                 value = NIL;
               }
 	    if (sequential)
-		bindArg(specials, symbol, value, ext);
+		bindArg(specials.toArray(arrayToUseForSpecials), 
+			symbol, value, ext, thread);
 	    else
 		nonSequentialVars.add(new Cons(symbol, value));
             varList = ((Cons)varList).cdr;
@@ -209,18 +193,17 @@
 	  {
 	    for (Cons x : nonSequentialVars)
 	      {
-		bindArg(specials, (Symbol)x.car(), x.cdr(), ext);
+		bindArg(specials.toArray(arrayToUseForSpecials), 
+			(Symbol)x.car(), x.cdr(), ext, thread);
 	      }
 	  }
         // Make sure free special declarations are visible in the body.
         // "The scope of free declarations specifically does not include
         // initialization forms for bindings established by the form
         // containing the declarations." (3.3.4)
-        while (specials != NIL)
+        for (Symbol symbol : specials)
           {
-            Symbol symbol = (Symbol) specials.car();
             ext.declareSpecial(symbol);
-            specials = ((Cons)specials).cdr;
           }
         return progn(body, ext, thread);
       }
@@ -264,7 +247,7 @@
                               symbol.writeToString() +
                               " with SYMBOL-MACROLET."));
                           }
-                        bind(symbol, new SymbolMacro(obj.cadr()), ext);
+                        bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread);
                       }
                     else
                       {



From ehuelsmann at common-lisp.net  Tue Jan  6 19:17:46 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Tue, 06 Jan 2009 19:17:46 +0000
Subject: [armedbear-cvs] r11549 - trunk/abcl
Message-ID: <E1LKHQw-0005eE-9m@common-lisp.net>

Author: ehuelsmann
Date: Tue Jan  6 19:17:45 2009
New Revision: 11549

Log:
Silence compile warnings in SBCL by moving a function up.

Modified:
   trunk/abcl/build-abcl.lisp

Modified: trunk/abcl/build-abcl.lisp
==============================================================================
--- trunk/abcl/build-abcl.lisp	(original)
+++ trunk/abcl/build-abcl.lisp	Tue Jan  6 19:17:45 2009
@@ -13,6 +13,14 @@
 
 (in-package #:build-abcl)
 
+(defun safe-namestring (pathname)
+  (let ((string (namestring pathname)))
+    (when (position #\space string)
+      (setf string (concatenate 'string "\"" string "\"")))
+    string))
+
+
+
 ;; Platform detection.
 
 (defun platform ()
@@ -439,12 +447,6 @@
   (with-current-directory ((merge-pathnames "java/awt/" *abcl-dir*))
     (delete-files (directory "*.class"))))
 
-(defun safe-namestring (pathname)
-  (let ((string (namestring pathname)))
-    (when (position #\space string)
-      (setf string (concatenate 'string "\"" string "\"")))
-    string))
-
 (defun build-abcl (&key force
                         (batch t)
                         compile-system



From ehuelsmann at common-lisp.net  Wed Jan  7 21:14:24 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 07 Jan 2009 21:14:24 +0000
Subject: [armedbear-cvs] r11550 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LKfjM-0002wJ-PE@common-lisp.net>

Author: ehuelsmann
Date: Wed Jan  7 21:14:23 2009
New Revision: 11550

Log:
Silence compiler warnings about deleting "Unused function CALL-NEXT-METHOD": it's being added
even if only NEXT-METHOD-P is called.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Wed Jan  7 21:14:23 2009
@@ -1580,6 +1580,7 @@
                              (funcall next-emfun (or cnm-args args))))
                        (next-method-p ()
                          (not (null next-emfun))))
+                  (declare (ignorable call-next-method next-method-p))
                   (apply #'(lambda ,lambda-list , at declarations , at body) args))))
             ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
              ;; Required parameters only.



From ehuelsmann at common-lisp.net  Thu Jan  8 20:24:45 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 08 Jan 2009 20:24:45 +0000
Subject: [armedbear-cvs] r11551 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LL1Qr-0003BN-8K@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan  8 20:24:45 2009
New Revision: 11551

Log:
Change the return value of Environment.isDeclaredSpecial() to include the
dynamic environment in case there's no record of the symbol in the lexical environment.

... And add a /little/ bit of JavaDoc.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Environment.java

Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Environment.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Environment.java	Thu Jan  8 20:24:45 2009
@@ -244,10 +244,16 @@
     vars.specialp = true;
   }
 
+    /** Return true if a symbol is declared special.
+     *
+     * If there is no binding in the current (lexical) environment,
+     * the current dynamic environment (thread) is checked.
+     */
   public boolean isDeclaredSpecial(LispObject var)
   {
     Binding binding = getBinding(var);
-    return binding != null ? binding.specialp : false;
+    return (binding != null) ? binding.specialp :
+        (LispThread.currentThread().getSpecialBinding(var) != null);
   }
 
   @Override



From astalla at common-lisp.net  Fri Jan  9 22:16:05 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Fri, 09 Jan 2009 22:16:05 +0000
Subject: [armedbear-cvs] r11552 - branches/scripting/j/src/org/armedbear/lisp
Message-ID: <E1LLPe9-0008GY-5h@common-lisp.net>

Author: astalla
Date: Fri Jan  9 22:16:04 2009
New Revision: 11552

Log:
- fixed a bug in print-object (java-class), thanks to logicmoo
- jproperty-value get/set gives better error messages when it fails


Modified:
   branches/scripting/j/src/org/armedbear/lisp/Java.java
   branches/scripting/j/src/org/armedbear/lisp/print-object.lisp

Modified: branches/scripting/j/src/org/armedbear/lisp/Java.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/Java.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/Java.java	Fri Jan  9 22:16:04 2009
@@ -706,7 +706,7 @@
 				PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
 				return new JavaObject(pd.getReadMethod().invoke(obj));
 			} catch (Exception e) {
-				ConditionThrowable t = new ConditionThrowable("Exception in accessing property");
+				ConditionThrowable t = new ConditionThrowable("Exception reading property");
 				t.initCause(e);
 				throw t;
 			}
@@ -718,16 +718,17 @@
 	                  "java-object property-name value") {
     	
     	public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable {
-			try {
-	            Object obj = javaObject.javaInstance();
-				PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
-				pd.getWriteMethod().invoke(obj, value.javaInstance());
-				return value;
-			} catch (Exception e) {
-				ConditionThrowable t = new ConditionThrowable("Exception in accessing property");
-				t.initCause(e);
-				throw t;
-			}
+	    Object obj = null;
+	    try {
+		obj = javaObject.javaInstance();
+		PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
+		pd.getWriteMethod().invoke(obj, value.javaInstance());
+		return value;
+	    } catch (Exception e) {
+		ConditionThrowable t = new ConditionThrowable("Exception writing property " + propertyName.writeToString() + " in object " + obj + " to " + value.writeToString());
+		t.initCause(e);
+		throw t;
+	    }
         }
     };
     

Modified: branches/scripting/j/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/print-object.lisp	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/print-object.lisp	Fri Jan  9 22:16:04 2009
@@ -38,7 +38,7 @@
   object)
 
 (defmethod print-object ((class java:java-class) stream)
-  (write-string (%write-to-string object) stream))
+  (write-string (%write-to-string class) stream))
 
 (defmethod print-object ((class class) stream)
   (print-unreadable-object (class stream :identity t)



From ehuelsmann at common-lisp.net  Sun Jan 11 08:29:21 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 11 Jan 2009 08:29:21 +0000
Subject: [armedbear-cvs] r11553 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LLvhB-0004s6-6G@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 11 08:29:20 2009
New Revision: 11553

Log:
Increase performance of LispThread.currentThread() by more than 50% (uncontended case).
MAPCAR-THREADS correctness: use a concurrent hashmap.

- Increases function initialization of most lisp functions (which call currentThread())
- Simplifies LispThread code (eliminating synchronized blocks and caching variables)

Modified:
   trunk/abcl/src/org/armedbear/lisp/LispThread.java

Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispThread.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispThread.java	Sun Jan 11 08:29:20 2009
@@ -33,59 +33,34 @@
 
 package org.armedbear.lisp;
 
-import java.util.WeakHashMap;
 import java.util.Iterator;
+import java.util.concurrent.ConcurrentHashMap;
 
 public final class LispThread extends LispObject
 {
     private static boolean use_fast_calls = false;
 
-    private static final Object lock = new Object();
+    // use a concurrent hashmap: we may want to add threads
+    // while at the same time iterating the hash
+    final private static ConcurrentHashMap<Thread,LispThread> map =
+       new ConcurrentHashMap<Thread,LispThread>();
 
-    private static WeakHashMap<Thread,LispThread> map =
-       new WeakHashMap<Thread,LispThread>();
-
-    private static Thread currentJavaThread;
-    private static LispThread currentLispThread;
-
-    public static final LispThread currentThread()
-    {
-        Thread javaThread = Thread.currentThread();
-        synchronized (lock) {
-            if (javaThread == currentJavaThread)
-                return currentLispThread;
-        }
-        LispThread lispThread = (LispThread) map.get(javaThread);
-        if (lispThread == null) {
-            lispThread = new LispThread(javaThread);
-            put(javaThread, lispThread);
-        }
-        synchronized (lock) {
-            currentJavaThread = javaThread;
-            currentLispThread = lispThread;
-        }
-        return lispThread;
-    }
-
-    private static void put(Thread javaThread, LispThread lispThread)
-    {
-        synchronized (lock) {
-            WeakHashMap<Thread,LispThread> m = new WeakHashMap<Thread,LispThread>(map);
-            m.put(javaThread, lispThread);
-            map = m;
+    private static ThreadLocal<LispThread> threads = new ThreadLocal<LispThread>(){
+        @Override
+        public LispThread initialValue() {
+            Thread thisThread = Thread.currentThread();
+            LispThread newThread = new LispThread(thisThread);
+            LispThread.map.put(thisThread,newThread);
+            return newThread;
         }
-    }
+    };
 
-    public static void remove(Thread javaThread)
+    public static final LispThread currentThread()
     {
-        synchronized (lock) {
-            WeakHashMap<Thread,LispThread> m = new WeakHashMap<Thread,LispThread>(map);
-            m.remove(javaThread);
-            map = m;
-        }
+        return threads.get();
     }
 
-    private final Thread javaThread;
+   private final Thread javaThread;
     private boolean destroyed;
     private final LispObject name;
     public SpecialBinding lastSpecialBinding;
@@ -121,12 +96,12 @@
                     }
                 }
                 finally {
-                    remove(javaThread);
+                    // make sure the thread is *always* removed from the hash again
+                    map.remove(Thread.currentThread());
                 }
             }
         };
         javaThread = new Thread(r);
-        put(javaThread, this);
         this.name = name;
         javaThread.setDaemon(true);
         javaThread.start();



From ehuelsmann at common-lisp.net  Sun Jan 11 09:40:41 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 11 Jan 2009 09:40:41 +0000
Subject: [armedbear-cvs] r11554 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LLwoD-0000MY-Lx@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 11 09:40:41 2009
New Revision: 11554

Log:
Followup to the introduction of compile-forms-and-maybe-emit-clear-values.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan 11 09:40:41 2009
@@ -682,7 +682,7 @@
 	 (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr
 	    do (compile-form form arg1 arg2)
 	    collecting form)))
-    (maybe-emit-clear-values forms-for-emit-clear)))
+    (apply #'maybe-emit-clear-values forms-for-emit-clear)))
 
 (defknown emit-unbox-fixnum () t)
 (defun emit-unbox-fixnum ()



From ehuelsmann at common-lisp.net  Mon Jan 12 21:26:37 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 12 Jan 2009 21:26:37 +0000
Subject: [armedbear-cvs] r11555 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LMUIv-00032n-Ko@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 12 21:26:36 2009
New Revision: 11555

Log:
Remove unused variable.

Modified:
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java	Mon Jan 12 21:26:36 2009
@@ -46,7 +46,6 @@
     this.elementType = elementType;
     totalSize = computeTotalSize(dimv);
     data = new LispObject[totalSize];
-    final LispObject initialElement;
     for (int i = totalSize; i-- > 0;)
       data[i] = Fixnum.ZERO;
   }



From mevenson at common-lisp.net  Thu Jan 15 10:07:44 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Thu, 15 Jan 2009 10:07:44 +0000
Subject: [armedbear-cvs] r11556 - trunk/abcl
Message-ID: <E1LNP8a-0006J1-I2@common-lisp.net>

Author: mevenson
Date: Thu Jan 15 10:07:39 2009
New Revision: 11556

Log:
Fix the Lisp based build system to include with the new Java classes in src/org/armedbear/util.

Fix 'abcl.asd' to work with the ASDF distributed with SBCL/CLISP by
removing obsoleted ':documentation' keywords.  ABCL's version of
'asdf.lisp' is really old, so should be replaced.

Add the location of src/org/armedbear/util classes to the auxillary
jar scripts.


Modified:
   trunk/abcl/abcl.asd
   trunk/abcl/build-abcl.lisp
   trunk/abcl/customizations.lisp.in
   trunk/abcl/make-jar.bat.in
   trunk/abcl/make-jar.in

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Thu Jan 15 10:07:39 2009
@@ -6,8 +6,8 @@
   (:use :cl :asdf))
 (in-package :abcl-asdf)
 
+;;; Wrapper for all ABCL ASDF definitions.
 (defsystem :abcl
-  :documentation "Wrapper for all ABCL ASDF definitions."
   :version "0.2.0")
 
 (defmethod perform :after ((o load-op) (c (eql (find-system 'abcl))))
@@ -18,8 +18,9 @@
   ;;; Additional test suite invocations would go here.
   (asdf:oos 'asdf:test-op :ansi-test-compiled :force t))
 
+;;; A collection of test suites for ABCL.
 (defsystem :test-abcl
-  :documentation "A collection of test suites for ABCL." 
+
   :version "0.3"
   :depends-on (:ansi-test-compiled :ansi-test-interpreted))
 
@@ -28,10 +29,9 @@
   (asdf:oos 'asdf:load-op :ansi-test-compiled :force t))
 
 (defsystem :ansi-test :version "0.1" :components
-     ((:module ansi-tests :pathname "test/lisp/ansi/"
-	       :documentation "GCL ANSI test suite."
-	       :components
-	      ((:file "package")))))
+     ;;; GCL ANSI test suite.
+     ((:module ansi-tests :pathname "test/lisp/ansi/" :components
+	       ((:file "package")))))
 (defsystem :ansi-test-interpreted :version "0,1" :depends-on (ansi-test))
 (defsystem :ansi-test-compiled :version "0.1" :depends-on (ansi-test))
 
@@ -43,9 +43,9 @@
   (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
 	   :compile-tests t))
 
-;;; Works for: abcl, sbcl, clisp
+;;; Build ABCL from a Lisp.
+;;; Works for: abcl, sbcl, clisp, cmu, lispworks, allegro, openmcl
 (defsystem :build-abcl 
-  :documentation "Build ABCL from a Lisp."
   :components 
 	   ((:module build :pathname ""  :components
 		     ((:file "build-abcl") 

Modified: trunk/abcl/build-abcl.lisp
==============================================================================
--- trunk/abcl/build-abcl.lisp	(original)
+++ trunk/abcl/build-abcl.lisp	Thu Jan 15 10:07:39 2009
@@ -258,7 +258,7 @@
   (let* ((source-files
           (append (with-current-directory (*abcl-dir*)
                     (directory "*.java"))
-                  (with-current-directory ((merge-pathnames "java/awt/" *abcl-dir*))
+                  (with-current-directory ((merge-pathnames "util/" *abcl-dir*))
                     (directory "*.java"))))
          (to-do ()))
     (if force

Modified: trunk/abcl/customizations.lisp.in
==============================================================================
--- trunk/abcl/customizations.lisp.in	(original)
+++ trunk/abcl/customizations.lisp.in	Thu Jan 15 10:07:39 2009
@@ -27,12 +27,12 @@
 (case *platform*
   (:windows
    (setq *jdk*           "C:\\Program Files\\Java\\jdk1.5.0_16\\")
-   #+(or) (setq *java-compiler* "jikes")
+   #+nil  (setq *java-compiler* "jikes")
    )
   (:darwin
    (setq *jdk*           "/usr/")
-   (setq *java-compiler* "jikes")
-   #+(or) (setq *jar*    "jar"))
+   #+nil (setq *java-compiler* "jikes")
+   #+nil (setq *jar*    "jar"))
   ((:linux :unknown)
    (setq *jdk*           "/home/peter/sun/jdk1.5.0_16/")
    (setq *jar*           "fastjar")))

Modified: trunk/abcl/make-jar.bat.in
==============================================================================
--- trunk/abcl/make-jar.bat.in	(original)
+++ trunk/abcl/make-jar.bat.in	Thu Jan 15 10:07:39 2009
@@ -1,6 +1,7 @@
 cd src
 @JAR@ cmf manifest-abcl ..\abcl.jar org\armedbear\lisp\*.class
- at JAR@ uf ..\abcl.jar org\armedbear\lisp\java\awt\*.class
- at JAR@ uf ..\abcl.jar org\armedbear\lisp\*.lisp org\armedbear\lisp\LICENSE
+ at JAR@ uf ..\abcl.jar org\armedbear\lisp\util\*.class
+ at JAR@ uf ..\abcl.jar org\armedbear\lisp\LICENSE
+ at JAR@ uf ..\abcl.jar org\armedbear\lisp\*.lisp 
 @JAR@ uf ..\abcl.jar org\armedbear\lisp\*.abcl
 @JAR@ uf ..\abcl.jar org\armedbear\lisp\*.cls

Modified: trunk/abcl/make-jar.in
==============================================================================
--- trunk/abcl/make-jar.in	(original)
+++ trunk/abcl/make-jar.in	Thu Jan 15 10:07:39 2009
@@ -1,8 +1,8 @@
 #!/bin/sh
 cd src
 @JAR@ cmf manifest-abcl ../abcl.jar org/armedbear/lisp/*.class
- at JAR@ uf ../abcl.jar org/armedbear/lisp/java/awt/*.class
 @JAR@ uf ../abcl.jar org/armedbear/lisp/LICENSE
 @JAR@ uf ../abcl.jar org/armedbear/lisp/*.lisp
 @JAR@ uf ../abcl.jar org/armedbear/lisp/*.abcl
+ at JAR@ uf ../abcl.jar org/armedbear/lisp/util/*.class
 find . -name '*.cls' | xargs @JAR@ uf ../abcl.jar



From ehuelsmann at common-lisp.net  Thu Jan 15 23:19:36 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 15 Jan 2009 23:19:36 +0000
Subject: [armedbear-cvs] r11557 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LNbUu-0002E3-8n@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan 15 23:19:35 2009
New Revision: 11557

Log:
Fix ticket #28: Expressly adjustable array not adjustable.

Renames adjustVector() to adjustArray() and implements adjustArray() on arrays.

Note: This is not the nicest solution; it removes 'private' modifiers, however,
  given the size of the commit, it seems like an issue to be resolved in a later
  cleanup of the Array vs Vector code.

Modified:
   trunk/abcl/src/org/armedbear/lisp/AbstractArray.java
   trunk/abcl/src/org/armedbear/lisp/AbstractVector.java
   trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java
   trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java
   trunk/abcl/src/org/armedbear/lisp/ComplexString.java
   trunk/abcl/src/org/armedbear/lisp/ComplexVector.java
   trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/NilVector.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java
   trunk/abcl/src/org/armedbear/lisp/SimpleString.java
   trunk/abcl/src/org/armedbear/lisp/SimpleVector.java
   trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java
   trunk/abcl/src/org/armedbear/lisp/adjust_array.java

Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/AbstractArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/AbstractArray.java	Thu Jan 15 23:19:35 2009
@@ -86,6 +86,16 @@
         return -1; // Not reached.
     }
 
+    public void setFillPointer(LispObject fillPointer) throws ConditionThrowable
+    {
+        setFillPointer(fillPointer.intValue());
+    }
+
+    public void setFillPointer(int fillPointer) throws ConditionThrowable
+    {
+        noFillPointer();
+    }
+
     public boolean isAdjustable()
     {
         return true;
@@ -211,7 +221,7 @@
         sb.append('(');
         if (this instanceof SimpleArray_T)
             sb.append("SIMPLE-");
-        sb.append("ARRAY T (");
+        sb.append("ARRAY " + getElementType().writeToString() + " (");
         for (int i = 0; i < dimv.length; i++) {
             sb.append(dimv[i]);
             if (i < dimv.length - 1)
@@ -305,4 +315,14 @@
             return 0;
         }
     }
+
+  public abstract AbstractArray adjustArray(int[] dims,
+                                              LispObject initialElement,
+                                              LispObject initialContents)
+    throws ConditionThrowable;
+
+  public abstract AbstractArray adjustArray(int[] dims,
+                                              AbstractArray displacedTo,
+                                              int displacement)
+    throws ConditionThrowable;
 }

Modified: trunk/abcl/src/org/armedbear/lisp/AbstractVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/AbstractVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/AbstractVector.java	Thu Jan 15 23:19:35 2009
@@ -297,13 +297,27 @@
       }
   }
 
-  public abstract AbstractVector adjustVector(int size,
+  public abstract AbstractArray adjustArray(int size,
                                               LispObject initialElement,
                                               LispObject initialContents)
     throws ConditionThrowable;
-
-  public abstract AbstractVector adjustVector(int size,
+  public abstract AbstractArray adjustArray(int size,
                                               AbstractArray displacedTo,
                                               int displacement)
     throws ConditionThrowable;
+
+
+  public AbstractArray adjustArray(int[] dims,
+                                              LispObject initialElement,
+                                              LispObject initialContents)
+    throws ConditionThrowable {
+      return adjustArray(dims[0], initialElement, initialContents);
+  }
+
+  public AbstractArray adjustArray(int[] dims,
+                                              AbstractArray displacedTo,
+                                              int displacement)
+    throws ConditionThrowable {
+      return adjustArray(dims[0], displacedTo, displacement);
+  }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java	Thu Jan 15 23:19:35 2009
@@ -258,7 +258,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -291,7 +291,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        AbstractArray displacedTo,
                                        int displacement)
     {

Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java	Thu Jan 15 23:19:35 2009
@@ -270,7 +270,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      LispObject initialElement,
                                      LispObject initialContents)
     throws ConditionThrowable
@@ -310,7 +310,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      AbstractArray displacedTo,
                                      int displacement)
   {

Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java	Thu Jan 15 23:19:35 2009
@@ -268,7 +268,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      LispObject initialElement,
                                      LispObject initialContents)
     throws ConditionThrowable
@@ -308,7 +308,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      AbstractArray displacedTo,
                                      int displacement)
   {

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray.java	Thu Jan 15 23:19:35 2009
@@ -37,7 +37,7 @@
 {
     private final int[] dimv;
     private final LispObject elementType;
-    private final int totalSize;
+    private int totalSize;
 
     // For non-displaced arrays.
     private LispObject[] data;
@@ -235,4 +235,57 @@
     {
         return writeToString(dimv);
     }
+
+    @Override
+    public AbstractArray adjustArray(int[] dims,
+                                              LispObject initialElement,
+                                              LispObject initialContents)
+            throws ConditionThrowable {
+        if (isAdjustable()) {
+            if (initialContents != NIL)
+                setInitialContents(0, dims, initialContents, 0);
+            else {
+                //### FIXME Take the easy way out: we don't want to reorganize
+                // all of the array code yet
+                SimpleArray_T tempArray = new SimpleArray_T(dims, elementType);
+                tempArray.fill(initialElement);
+                SimpleArray_T.copyArray(this, tempArray);
+                this.data = tempArray.data;
+
+                for (int i = 0; i < dims.length; i++)
+                    dimv[i] = dims[i];
+            }
+            return this;
+        } else {
+            if (initialContents != NIL)
+                return new ComplexArray(dims, elementType, initialContents);
+            else {
+                ComplexArray newArray = new ComplexArray(dims, elementType);
+                newArray.fill(initialElement);
+                return newArray;
+            }
+        }
+    }
+
+    @Override
+    public AbstractArray adjustArray(int[] dims,
+                                              AbstractArray displacedTo,
+                                              int displacement)
+            throws ConditionThrowable {
+        if (isAdjustable()) {
+            for (int i = 0; i < dims.length; i++)
+                dimv[i] = dims[i];
+
+            this.data = null;
+            this.array = displacedTo;
+            this.displacement = displacement;
+            this.totalSize = computeTotalSize(dims);
+
+            return this;
+        } else {
+            ComplexArray a = new ComplexArray(dims, displacedTo, displacement);
+            
+            return a;
+        }
+    }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java	Thu Jan 15 23:19:35 2009
@@ -36,7 +36,7 @@
 public final class ComplexArray_UnsignedByte32 extends AbstractArray
 {
     private final int[] dimv;
-    private final int totalSize;
+    private int totalSize;
 
     // For non-displaced arrays.
     // FIXME We should really use an array of unboxed values!
@@ -231,4 +231,58 @@
     {
         return writeToString(dimv);
     }
+
+
+    @Override
+    public AbstractArray adjustArray(int[] dims,
+                                              LispObject initialElement,
+                                              LispObject initialContents)
+            throws ConditionThrowable {
+        if (isAdjustable()) {
+            if (initialContents != NIL)
+                setInitialContents(0, dims, initialContents, 0);
+            else {
+                //### FIXME Take the easy way out: we don't want to reorganize
+                // all of the array code yet
+                SimpleArray_UnsignedByte32 tempArray = new SimpleArray_UnsignedByte32(dims, getElementType());
+                tempArray.fill(initialElement);
+                SimpleArray_UnsignedByte32.copyArray(this, tempArray);
+                this.data = tempArray.data;
+
+                for (int i = 0; i < dims.length; i++)
+                    dimv[i] = dims[i];
+            }
+            return this;
+        } else {
+            if (initialContents != NIL)
+                return new ComplexArray_UnsignedByte32(dims, initialContents);
+            else {
+                ComplexArray_UnsignedByte32 newArray = new ComplexArray_UnsignedByte32(dims);
+                newArray.fill(initialElement);
+                return newArray;
+            }
+        }
+    }
+
+    @Override
+    public AbstractArray adjustArray(int[] dims,
+                                              AbstractArray displacedTo,
+                                              int displacement)
+            throws ConditionThrowable {
+        if (isAdjustable()) {
+            for (int i = 0; i < dims.length; i++)
+                dimv[i] = dims[i];
+
+            this.data = null;
+            this.array = displacedTo;
+            this.displacement = displacement;
+            this.totalSize = computeTotalSize(dims);
+
+            return this;
+        } else {
+            ComplexArray_UnsignedByte32 a = new ComplexArray_UnsignedByte32(dims, displacedTo, displacement);
+
+            return a;
+        }
+    }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java	Thu Jan 15 23:19:35 2009
@@ -36,7 +36,7 @@
 public final class ComplexArray_UnsignedByte8 extends AbstractArray
 {
     private final int[] dimv;
-    private final int totalSize;
+    private int totalSize;
 
     // For non-displaced arrays.
     private byte[] data;
@@ -233,4 +233,58 @@
         }
         return writeToString(dimv);
     }
+
+
+    @Override
+    public AbstractArray adjustArray(int[] dims,
+                                              LispObject initialElement,
+                                              LispObject initialContents)
+            throws ConditionThrowable {
+        if (isAdjustable()) {
+            if (initialContents != NIL)
+                setInitialContents(0, dims, initialContents, 0);
+            else {
+                //### FIXME Take the easy way out: we don't want to reorganize
+                // all of the array code yet
+                SimpleArray_UnsignedByte8 tempArray = new SimpleArray_UnsignedByte8(dims, getElementType());
+                tempArray.fill(initialElement);
+                SimpleArray_UnsignedByte8.copyArray(this, tempArray);
+                this.data = tempArray.data;
+
+                for (int i = 0; i < dims.length; i++)
+                    dimv[i] = dims[i];
+            }
+            return this;
+        } else {
+            if (initialContents != NIL)
+                return new ComplexArray_UnsignedByte8(dims, initialContents);
+            else {
+                ComplexArray_UnsignedByte8 newArray = new ComplexArray_UnsignedByte8(dims);
+                newArray.fill(initialElement);
+                return newArray;
+            }
+        }
+    }
+
+    @Override
+    public AbstractArray adjustArray(int[] dims,
+                                              AbstractArray displacedTo,
+                                              int displacement)
+            throws ConditionThrowable {
+        if (isAdjustable()) {
+            for (int i = 0; i < dims.length; i++)
+                dimv[i] = dims[i];
+
+            this.data = null;
+            this.array = displacedTo;
+            this.displacement = displacement;
+            this.totalSize = computeTotalSize(dims);
+
+            return this;
+        } else {
+            ComplexArray_UnsignedByte8 a = new ComplexArray_UnsignedByte8(dims, displacedTo, displacement);
+
+            return a;
+        }
+    }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java	Thu Jan 15 23:19:35 2009
@@ -319,7 +319,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -380,7 +380,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int size, AbstractArray displacedTo,
+    public AbstractVector adjustArray(int size, AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable
     {

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexString.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexString.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexString.java	Thu Jan 15 23:19:35 2009
@@ -597,7 +597,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      LispObject initialElement,
                                      LispObject initialContents)
     throws ConditionThrowable
@@ -674,7 +674,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      AbstractArray displacedTo,
                                      int displacement)
     throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexVector.java	Thu Jan 15 23:19:35 2009
@@ -365,7 +365,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -412,7 +412,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java	Thu Jan 15 23:19:35 2009
@@ -367,7 +367,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -416,7 +416,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java	Thu Jan 15 23:19:35 2009
@@ -379,7 +379,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -429,7 +429,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/NilVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/NilVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/NilVector.java	Thu Jan 15 23:19:35 2009
@@ -247,7 +247,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -258,7 +258,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int size, AbstractArray displacedTo,
+    public AbstractVector adjustArray(int size, AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable
     {

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java	Thu Jan 15 23:19:35 2009
@@ -38,7 +38,7 @@
   private final int[] dimv;
   private final LispObject elementType;
   private final int totalSize;
-  private final LispObject[] data;
+  final LispObject[] data;
 
   public SimpleArray_T(int[] dimv, LispObject elementType)
   {
@@ -89,6 +89,14 @@
     setInitialContents(0, dimv, initialContents, 0);
   }
 
+  public SimpleArray_T(final int[] dimv, final LispObject[] initialData,
+          final LispObject elementType) {
+      this.dimv = dimv;
+      this.elementType = elementType;
+      this.data = initialData;
+      this.totalSize = computeTotalSize(dimv);
+  }
+
   private int setInitialContents(int axis, int[] dims, LispObject contents,
                                  int index)
     throws ConditionThrowable
@@ -314,6 +322,7 @@
     return writeToString(dimv);
   }
 
+  @Override
   public AbstractArray adjustArray(int[] dimv, LispObject initialElement,
                                    LispObject initialContents)
     throws ConditionThrowable
@@ -330,12 +339,13 @@
             return newArray;
           }
       }
-    // New dimensions are identical to old dimensions.
-    return this;
+    // New dimensions are identical to old dimensions, yet
+    // we're not mutable, so, we need to return a new array
+    return new SimpleArray_T(dimv, data.clone(), elementType);
   }
 
   // Copy a1 to a2 for index tuples that are valid for both arrays.
-  private static void copyArray(AbstractArray a1, AbstractArray a2)
+  static void copyArray(AbstractArray a1, AbstractArray a2)
     throws ConditionThrowable
   {
     Debug.assertTrue(a1.getRank() == a2.getRank());
@@ -366,6 +376,7 @@
       }
   }
 
+  @Override
   public AbstractArray adjustArray(int[] dimv, AbstractArray displacedTo,
                                    int displacement)
   {

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java	Thu Jan 15 23:19:35 2009
@@ -39,7 +39,7 @@
     private final int totalSize;
 
     // FIXME We should really use an array of unboxed values!
-    private final LispObject[] data;
+    final LispObject[] data;
 
     public SimpleArray_UnsignedByte32(int[] dimv)
     {
@@ -309,7 +309,7 @@
     }
 
     // Copy a1 to a2 for index tuples that are valid for both arrays.
-    private static void copyArray(AbstractArray a1, AbstractArray a2)
+    static void copyArray(AbstractArray a1, AbstractArray a2)
         throws ConditionThrowable
     {
         Debug.assertTrue(a1.getRank() == a2.getRank());

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java	Thu Jan 15 23:19:35 2009
@@ -37,7 +37,7 @@
 {
     private final int[] dimv;
     private final int totalSize;
-    private final byte[] data;
+    final byte[] data;
 
     public SimpleArray_UnsignedByte8(int[] dimv)
     {
@@ -306,7 +306,7 @@
     }
 
     // Copy a1 to a2 for index tuples that are valid for both arrays.
-    private static void copyArray(AbstractArray a1, AbstractArray a2)
+    static void copyArray(AbstractArray a1, AbstractArray a2)
         throws ConditionThrowable
     {
         Debug.assertTrue(a1.getRank() == a2.getRank());

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java	Thu Jan 15 23:19:35 2009
@@ -194,7 +194,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -239,7 +239,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleString.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleString.java	Thu Jan 15 23:19:35 2009
@@ -460,7 +460,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        LispObject initialElement,
                                        LispObject initialContents)
         throws ConditionThrowable
@@ -495,7 +495,7 @@
     }
 
     @Override
-    public AbstractVector adjustVector(int newCapacity,
+    public AbstractVector adjustArray(int newCapacity,
                                        AbstractArray displacedTo,
                                        int displacement)
         throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleVector.java	Thu Jan 15 23:19:35 2009
@@ -331,7 +331,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      LispObject initialElement,
                                      LispObject initialContents)
     throws ConditionThrowable
@@ -371,7 +371,7 @@
   }
 
   @Override
-  public AbstractVector adjustVector(int newCapacity,
+  public AbstractVector adjustArray(int newCapacity,
                                      AbstractArray displacedTo,
                                      int displacement)
   {

Modified: trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java	Thu Jan 15 23:19:35 2009
@@ -162,4 +162,31 @@
         sb.append(" NIL");
         return unreadableString(sb.toString());
     }
+
+  @Override
+  public AbstractArray adjustArray(int[] dims,
+                                              LispObject initialElement,
+                                              LispObject initialContents)
+    throws ConditionThrowable {
+      if (isAdjustable()) {
+          if (initialContents != NIL)
+              data = initialContents;
+          else
+              data = initialElement;
+          return this;
+      } else {
+          return new ZeroRankArray(elementType,
+                  initialContents != NIL ? initialContents : initialElement,
+                  false);
+      }
+  }
+
+  @Override
+  public AbstractArray adjustArray(int[] dims,
+                                              AbstractArray displacedTo,
+                                              int displacement)
+    throws ConditionThrowable {
+      error(new TypeError("Displacement not supported for array of rank 0."));
+      return null;
+  }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/adjust_array.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/adjust_array.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/adjust_array.java	Thu Jan 15 23:19:35 2009
@@ -67,9 +67,8 @@
             return error(new LispError("ADJUST-ARRAY: incompatible element type."));
         }
         if (array.getRank() == 0) {
-            if (initialContentsProvided != NIL)
-                array.aset(0, initialContents);
-            return array;
+            return array.adjustArray(new int[0], NIL,
+                    (initialContentsProvided != NIL) ? initialContents : initialElement);
         }
         if (initialElementProvided == NIL && array.getElementType() == T)
             initialElement = Fixnum.ZERO;
@@ -81,18 +80,18 @@
                 newSize = Fixnum.getValue(dimensions);
             if (array instanceof AbstractVector) {
                 AbstractVector v = (AbstractVector) array;
-                AbstractVector v2;
+                AbstractArray v2;
                 if (displacedTo != NIL) {
                     final int displacement;
                     if (displacedIndexOffset == NIL)
                         displacement = 0;
                     else
                         displacement = Fixnum.getValue(displacedIndexOffset);
-                    v2 = v.adjustVector(newSize,
+                    v2 = v.adjustArray(newSize,
                                         checkArray(displacedTo),
                                         displacement);
                 } else {
-                    v2 = v.adjustVector(newSize,
+                    v2 = v.adjustArray(newSize,
                                         initialElement,
                                         initialContents);
                 }
@@ -112,24 +111,21 @@
             }
         } else
             dimv[0] = Fixnum.getValue(dimensions);
-        if (array instanceof SimpleArray_T) {
-            SimpleArray_T a = (SimpleArray_T) array;
-            if (displacedTo != NIL) {
-                final int displacement;
-                if (displacedIndexOffset == NIL)
-                    displacement = 0;
-                else
-                    displacement = Fixnum.getValue(displacedIndexOffset);
-                return a.adjustArray(dimv,
+
+        if (displacedTo != NIL) {
+            final int displacement;
+            if (displacedIndexOffset == NIL)
+                displacement = 0;
+            else
+                displacement = Fixnum.getValue(displacedIndexOffset);
+            return array.adjustArray(dimv,
                                      checkArray(displacedTo),
                                      displacement);
-            } else {
-                return a.adjustArray(dimv,
+        } else {
+            return array.adjustArray(dimv,
                                      initialElement,
                                      initialContents);
-            }
         }
-        return error(new LispError("ADJUST-ARRAY: unsupported case."));
     }
 
     private static final Primitive _ADJUST_ARRAY = new adjust_array();



From astalla at common-lisp.net  Thu Jan 15 23:51:04 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Thu, 15 Jan 2009 23:51:04 +0000
Subject: [armedbear-cvs] r11558 - in
	branches/scripting/j/src/org/armedbear/lisp/scripting: . lisp
Message-ID: <E1LNbzM-0004Hl-Tw@common-lisp.net>

Author: astalla
Date: Thu Jan 15 23:51:04 2009
New Revision: 11558

Log:
Solved a bug in invokeFunction (the symbol was not derived correctly from 
the function name)


Modified:
   branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
   branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp

Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java	Thu Jan 15 23:51:04 2009
@@ -247,7 +247,11 @@
 		if(i < 0) { 
 			return findSymbol(name, null);
 		} else {
+		    if((i < name.length() - 1) && (name.charAt(i + 1) == ':')) {
+			return findSymbol(name.substring(i + 2), name.substring(0, i));
+		    } else {
 			return findSymbol(name.substring(i + 1), name.substring(0, i));
+		    }
 		}
 	}
 	
@@ -396,46 +400,51 @@
 	
 	@Override
 	public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException {
-		try {
-			Symbol s = findSymbol(name);
-			if(s != null) {
-				LispObject f = s.getSymbolFunction();
-				if(f != null && f instanceof Function) {
-					LispObject[] wrappedArgs = new LispObject[args.length];
-					for(int i = 0; i < args.length; ++i) {
-						wrappedArgs[i] = toLisp(args[i]);
-					}
-					switch(args.length) {
-						case 0:
-							return LispThread.currentThread().execute(f);
-						case 1:
-							return LispThread.currentThread().execute(f, wrappedArgs[0]);
-						case 2:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1]);
-						case 3:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2]);							
-						case 4:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3]);
-						case 5:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4]);
-						case 6:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5]);
-						case 7:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6]);
-						case 8:
-							return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6], wrappedArgs[7]);
-						default:
-							return LispThread.currentThread().execute(f, wrappedArgs);
-					} 
-				} else {
-					throw new NoSuchMethodException(name);
-				}
-			} else {
-				throw new NoSuchMethodException(name);
+	    try {
+		Symbol s;
+		if(name.indexOf(':') >= 0) {
+		    s = findSymbol(name);
+		} else {
+		    s = findSymbol(name, "ABCL-SCRIPT-USER");
+		}
+		if(s != null) {
+		    LispObject f = s.getSymbolFunction();
+		    if(f != null && f instanceof Function) {
+			LispObject[] wrappedArgs = new LispObject[args.length];
+			for(int i = 0; i < args.length; ++i) {
+			    wrappedArgs[i] = toLisp(args[i]);
 			}
-		} catch (ConditionThrowable e) {
-			throw new ScriptException(new RuntimeException(e));
+			switch(args.length) {
+			case 0:
+			    return LispThread.currentThread().execute(f);
+			case 1:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0]);
+			case 2:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1]);
+			case 3:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2]);							
+			case 4:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3]);
+			case 5:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4]);
+			case 6:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5]);
+			case 7:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6]);
+			case 8:
+			    return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6], wrappedArgs[7]);
+			default:
+			    return LispThread.currentThread().execute(f, wrappedArgs);
+			} 
+		    } else {
+			throw new NoSuchMethodException(name);
+		    }
+		} else {
+		    throw new NoSuchMethodException(name);
 		}
+	    } catch (ConditionThrowable e) {
+		throw new ScriptException(new RuntimeException(e));
+	    }
 	}
 
 	@Override
@@ -467,8 +476,8 @@
 	@Override
 	public CompiledScript compile(String script) throws ScriptException {
 		try {
-			Function f = (Function) compileScript.execute(new SimpleString(script));
-			return new AbclCompiledScript(f);
+		    Function f = (Function) compileScript.execute(new SimpleString(script));
+		    return new AbclCompiledScript(f);
 		} catch (ConditionThrowable e) {
 			throw new ScriptException(new Exception(e));
 		} catch(ClassCastException e) {

Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp	Thu Jan 15 23:51:04 2009
@@ -83,10 +83,12 @@
     `((funcall ,function))))
 
 (defun compile-script (code-string)
-  (let ((*package* (find-package :abcl-script-user)))
-    (eval `(compile nil
-	    (lambda ()
-	      ,@(read-from-string (concatenate 'string "(" code-string ")")))))))
+  (eval 
+   `(compile
+     nil
+     (lambda ()
+       ,@(let ((*package* (find-package :abcl-script-user)))
+	      (read-from-string (concatenate 'string "(" code-string ")")))))))
 
 
 ;;Java interface implementation



From astalla at common-lisp.net  Thu Jan 15 23:52:27 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Thu, 15 Jan 2009 23:52:27 +0000
Subject: [armedbear-cvs] r11559 - branches/scripting/j/src/org/armedbear/lisp
Message-ID: <E1LNc0h-0004LC-Lf@common-lisp.net>

Author: astalla
Date: Thu Jan 15 23:52:27 2009
New Revision: 11559

Log:
Better handling of java<->lisp value conversion in (get/set) 
jproperty-value


Modified:
   branches/scripting/j/src/org/armedbear/lisp/Java.java

Modified: branches/scripting/j/src/org/armedbear/lisp/Java.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/Java.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/Java.java	Thu Jan 15 23:52:27 2009
@@ -704,7 +704,14 @@
 			try {
 				Object obj = javaObject.javaInstance();
 				PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
-				return new JavaObject(pd.getReadMethod().invoke(obj));
+				Object value = pd.getReadMethod().invoke(obj);
+				if(value instanceof LispObject) {
+				    return (LispObject) value;
+				} else if(value != null) {
+				    return new JavaObject(value);
+				} else {
+				    return NIL;
+				}
 			} catch (Exception e) {
 				ConditionThrowable t = new ConditionThrowable("Exception reading property");
 				t.initCause(e);
@@ -722,7 +729,18 @@
 	    try {
 		obj = javaObject.javaInstance();
 		PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
-		pd.getWriteMethod().invoke(obj, value.javaInstance());
+		Object jValue;
+		if(value == NIL) {
+		    if(Boolean.TYPE.equals(pd.getPropertyType()) ||
+		       Boolean.class.equals(pd.getPropertyType())) {
+			jValue = false;
+		    } else {
+			jValue = null;
+		    }
+		} else {
+		    jValue = value.javaInstance();
+		}
+		pd.getWriteMethod().invoke(obj, jValue);
 		return value;
 	    } catch (Exception e) {
 		ConditionThrowable t = new ConditionThrowable("Exception writing property " + propertyName.writeToString() + " in object " + obj + " to " + value.writeToString());



From ehuelsmann at common-lisp.net  Fri Jan 16 20:49:12 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 16 Jan 2009 20:49:12 +0000
Subject: [armedbear-cvs] r11560 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LNvcu-0001Dw-TM@common-lisp.net>

Author: ehuelsmann
Date: Fri Jan 16 20:49:03 2009
New Revision: 11560

Log:
Followup to r11557: Fixes ADJUST-ARRAY for the special cases
of (UNSIGNED-BYTE 8) and (UNSIGNED-BYTE 32).

Modified:
   trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java	Fri Jan 16 20:49:03 2009
@@ -244,7 +244,7 @@
             else {
                 //### FIXME Take the easy way out: we don't want to reorganize
                 // all of the array code yet
-                SimpleArray_UnsignedByte32 tempArray = new SimpleArray_UnsignedByte32(dims, getElementType());
+                SimpleArray_UnsignedByte32 tempArray = new SimpleArray_UnsignedByte32(dims);
                 tempArray.fill(initialElement);
                 SimpleArray_UnsignedByte32.copyArray(this, tempArray);
                 this.data = tempArray.data;

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java	Fri Jan 16 20:49:03 2009
@@ -246,7 +246,7 @@
             else {
                 //### FIXME Take the easy way out: we don't want to reorganize
                 // all of the array code yet
-                SimpleArray_UnsignedByte8 tempArray = new SimpleArray_UnsignedByte8(dims, getElementType());
+                SimpleArray_UnsignedByte8 tempArray = new SimpleArray_UnsignedByte8(dims);
                 tempArray.fill(initialElement);
                 SimpleArray_UnsignedByte8.copyArray(this, tempArray);
                 this.data = tempArray.data;



From ehuelsmann at common-lisp.net  Sat Jan 17 10:24:41 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 17 Jan 2009 10:24:41 +0000
Subject: [armedbear-cvs] r11561 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LO8M5-0004Dx-Sy@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 17 10:24:40 2009
New Revision: 11561

Log:
Don't check the value of initialContent to see whether it was provided; it may be NIL.

Modified:
   trunk/abcl/src/org/armedbear/lisp/adjust_array.java

Modified: trunk/abcl/src/org/armedbear/lisp/adjust_array.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/adjust_array.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/adjust_array.java	Sat Jan 17 10:24:40 2009
@@ -58,7 +58,7 @@
         LispObject fillPointer = args[7];
         LispObject displacedTo = args[8];
         LispObject displacedIndexOffset = args[9];
-        if (initialElementProvided != NIL && initialContents != NIL) {
+        if (initialElementProvided != NIL && initialContentsProvided != NIL) {
             return error(new LispError("ADJUST-ARRAY: cannot specify both initial element and initial contents."));
         }
         if (elementType != array.getElementType() &&



From ehuelsmann at common-lisp.net  Sat Jan 17 13:57:00 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 17 Jan 2009 13:57:00 +0000
Subject: [armedbear-cvs] r11562 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOBfY-0004Yi-EL@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 17 13:56:59 2009
New Revision: 11562

Log:
Change and document the internal adjustArray() protocol: we can't use NIL as a marker for "absent initial contents": It's valid for ZeroRankArray.


Modified:
   trunk/abcl/src/org/armedbear/lisp/AbstractArray.java
   trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java
   trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java
   trunk/abcl/src/org/armedbear/lisp/ComplexString.java
   trunk/abcl/src/org/armedbear/lisp/ComplexVector.java
   trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java
   trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java
   trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java
   trunk/abcl/src/org/armedbear/lisp/SimpleString.java
   trunk/abcl/src/org/armedbear/lisp/SimpleVector.java
   trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java
   trunk/abcl/src/org/armedbear/lisp/adjust_array.java

Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/AbstractArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/AbstractArray.java	Sat Jan 17 13:56:59 2009
@@ -316,13 +316,30 @@
         }
     }
 
-  public abstract AbstractArray adjustArray(int[] dims,
+    /** Returns a newly allocated array or the current array with
+     * adjusted dimensions.
+     *
+     * @param dims
+     * @param initialElement @c null if none
+     * @param initialContents @c null if none
+     * @return @c this or a new array
+     * @throws org.armedbear.lisp.ConditionThrowable
+     */
+    public abstract AbstractArray adjustArray(int[] dims,
                                               LispObject initialElement,
                                               LispObject initialContents)
-    throws ConditionThrowable;
+        throws ConditionThrowable;
 
-  public abstract AbstractArray adjustArray(int[] dims,
+    /**
+     * 
+     * @param dims
+     * @param displacedTo
+     * @param displacement
+     * @return
+     * @throws org.armedbear.lisp.ConditionThrowable
+     */
+    public abstract AbstractArray adjustArray(int[] dims,
                                               AbstractArray displacedTo,
                                               int displacement)
-    throws ConditionThrowable;
+        throws ConditionThrowable;
 }

Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java	Sat Jan 17 13:56:59 2009
@@ -263,7 +263,7 @@
                                        LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL) {
+        if (initialContents != null) {
             LispObject[] newElements = new LispObject[newCapacity];
             if (initialContents.listp()) {
                 LispObject list = initialContents;
@@ -282,8 +282,9 @@
             LispObject[] newElements = new LispObject[newCapacity];
             System.arraycopy(elements, 0, newElements, 0,
                              Math.min(capacity, newCapacity));
-            for (int i = capacity; i < newCapacity; i++)
-                newElements[i] = initialElement;
+            if (initialElement != null)
+                for (int i = capacity; i < newCapacity; i++)
+                    newElements[i] = initialElement;
             return new BasicVector_UnsignedByte16(newElements);
         }
         // No change.

Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java	Sat Jan 17 13:56:59 2009
@@ -275,7 +275,7 @@
                                      LispObject initialContents)
     throws ConditionThrowable
   {
-    if (initialContents != NIL)
+    if (initialContents != null)
       {
         LispObject[] newElements = new LispObject[newCapacity];
         if (initialContents.listp())
@@ -301,8 +301,9 @@
         LispObject[] newElements = new LispObject[newCapacity];
         System.arraycopy(elements, 0, newElements, 0,
                          Math.min(capacity, newCapacity));
-        for (int i = capacity; i < newCapacity; i++)
-          newElements[i] = initialElement;
+        if (initialElement != null)
+            for (int i = capacity; i < newCapacity; i++)
+                newElements[i] = initialElement;
         return new BasicVector_UnsignedByte32(newElements);
       }
     // No change.

Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java	Sat Jan 17 13:56:59 2009
@@ -273,7 +273,7 @@
                                      LispObject initialContents)
     throws ConditionThrowable
   {
-    if (initialContents != NIL)
+    if (initialContents != null)
       {
         LispObject[] newElements = new LispObject[newCapacity];
         if (initialContents.listp())
@@ -299,8 +299,9 @@
         LispObject[] newElements = new LispObject[newCapacity];
         System.arraycopy(elements, 0, newElements, 0,
                          Math.min(capacity, newCapacity));
-        for (int i = capacity; i < newCapacity; i++)
-          newElements[i] = initialElement;
+        if (initialElement != null)
+            for (int i = capacity; i < newCapacity; i++)
+                newElements[i] = initialElement;
         return new BasicVector_UnsignedByte8(newElements);
       }
     // No change.

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray.java	Sat Jan 17 13:56:59 2009
@@ -242,13 +242,14 @@
                                               LispObject initialContents)
             throws ConditionThrowable {
         if (isAdjustable()) {
-            if (initialContents != NIL)
+            if (initialContents != null)
                 setInitialContents(0, dims, initialContents, 0);
             else {
                 //### FIXME Take the easy way out: we don't want to reorganize
                 // all of the array code yet
                 SimpleArray_T tempArray = new SimpleArray_T(dims, elementType);
-                tempArray.fill(initialElement);
+                if (initialElement != null)
+                    tempArray.fill(initialElement);
                 SimpleArray_T.copyArray(this, tempArray);
                 this.data = tempArray.data;
 
@@ -257,11 +258,12 @@
             }
             return this;
         } else {
-            if (initialContents != NIL)
+            if (initialContents != null)
                 return new ComplexArray(dims, elementType, initialContents);
             else {
                 ComplexArray newArray = new ComplexArray(dims, elementType);
-                newArray.fill(initialElement);
+                if (initialElement != null)
+                    newArray.fill(initialElement);
                 return newArray;
             }
         }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java	Sat Jan 17 13:56:59 2009
@@ -239,13 +239,14 @@
                                               LispObject initialContents)
             throws ConditionThrowable {
         if (isAdjustable()) {
-            if (initialContents != NIL)
+            if (initialContents != null)
                 setInitialContents(0, dims, initialContents, 0);
             else {
                 //### FIXME Take the easy way out: we don't want to reorganize
                 // all of the array code yet
                 SimpleArray_UnsignedByte32 tempArray = new SimpleArray_UnsignedByte32(dims);
-                tempArray.fill(initialElement);
+                if (initialElement != null)
+                    tempArray.fill(initialElement);
                 SimpleArray_UnsignedByte32.copyArray(this, tempArray);
                 this.data = tempArray.data;
 
@@ -254,11 +255,12 @@
             }
             return this;
         } else {
-            if (initialContents != NIL)
+            if (initialContents != null)
                 return new ComplexArray_UnsignedByte32(dims, initialContents);
             else {
                 ComplexArray_UnsignedByte32 newArray = new ComplexArray_UnsignedByte32(dims);
-                newArray.fill(initialElement);
+                if (initialElement != null)
+                    newArray.fill(initialElement);
                 return newArray;
             }
         }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java	Sat Jan 17 13:56:59 2009
@@ -241,13 +241,14 @@
                                               LispObject initialContents)
             throws ConditionThrowable {
         if (isAdjustable()) {
-            if (initialContents != NIL)
+            if (initialContents != null)
                 setInitialContents(0, dims, initialContents, 0);
             else {
                 //### FIXME Take the easy way out: we don't want to reorganize
                 // all of the array code yet
                 SimpleArray_UnsignedByte8 tempArray = new SimpleArray_UnsignedByte8(dims);
-                tempArray.fill(initialElement);
+                if (initialElement != null)
+                    tempArray.fill(initialElement);
                 SimpleArray_UnsignedByte8.copyArray(this, tempArray);
                 this.data = tempArray.data;
 
@@ -256,11 +257,12 @@
             }
             return this;
         } else {
-            if (initialContents != NIL)
+            if (initialContents != null)
                 return new ComplexArray_UnsignedByte8(dims, initialContents);
             else {
                 ComplexArray_UnsignedByte8 newArray = new ComplexArray_UnsignedByte8(dims);
-                newArray.fill(initialElement);
+                if (initialElement != null)
+                    newArray.fill(initialElement);
                 return newArray;
             }
         }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexBitVector.java	Sat Jan 17 13:56:59 2009
@@ -345,7 +345,7 @@
             int size = newCapacity >>> 6;
             if ((newCapacity & LONG_MASK) != 0)
                 ++size;
-            if (initialContents != NIL) {
+            if (initialContents != null) {
                 bits = new long[size];
                 capacity = newCapacity;
                 if (initialContents.listp()) {
@@ -364,7 +364,7 @@
                 System.arraycopy(bits, 0, newBits, 0,
                                  Math.min(bits.length, newBits.length));
                 bits = newBits;
-                if (newCapacity > capacity) {
+                if (newCapacity > capacity && initialElement != null) {
                     int n = Fixnum.getValue(initialElement);
                     if (n == 1)
                         for (int i = capacity; i < newCapacity; i++)

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexString.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexString.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexString.java	Sat Jan 17 13:56:59 2009
@@ -602,7 +602,7 @@
                                      LispObject initialContents)
     throws ConditionThrowable
   {
-    if (initialContents != NIL)
+    if (initialContents != null)
       {
         // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE-
         // ARRAY. In this case none of the original contents of array
@@ -658,7 +658,7 @@
                              Math.min(capacity, newCapacity));
             chars = newElements;
           }
-        if (initialElement != NIL && capacity < newCapacity)
+        if (initialElement != null && capacity < newCapacity)
           {
             // Initialize new elements.
             final char c = LispCharacter.getValue(initialElement);

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexVector.java	Sat Jan 17 13:56:59 2009
@@ -370,7 +370,7 @@
                                        LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL) {
+        if (initialContents != null) {
             // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE-
             // ARRAY. In this case none of the original contents of array
             // appears in the resulting array."
@@ -401,8 +401,9 @@
                 elements = newElements;
             }
             // Initialize new elements (if any).
-            for (int i = capacity; i < newCapacity; i++)
-                elements[i] = initialElement;
+            if (initialElement != null)
+                for (int i = capacity; i < newCapacity; i++)
+                    elements[i] = initialElement;
         }
         capacity = newCapacity;
         array = null;

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java	Sat Jan 17 13:56:59 2009
@@ -372,7 +372,7 @@
                                        LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL) {
+        if (initialContents != null) {
             // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE-
             // ARRAY. In this case none of the original contents of array
             // appears in the resulting array."
@@ -403,7 +403,7 @@
                 elements = newElements;
             }
             // Initialize new elements (if aapplicable).
-            if (initialElement != NIL) {
+            if (initialElement != null) {
                 for (int i = capacity; i < newCapacity; i++)
                     elements[i] = initialElement;
             }

Modified: trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java	Sat Jan 17 13:56:59 2009
@@ -384,7 +384,7 @@
                                        LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL) {
+        if (initialContents != null) {
             // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE-
             // ARRAY. In this case none of the original contents of array
             // appears in the resulting array."
@@ -415,7 +415,7 @@
                 elements = newElements;
             }
             // Initialize new elements (if aapplicable).
-            if (initialElement != NIL) {
+            if (initialElement != null) {
                 byte b = coerceLispObjectToJavaByte(initialElement);
                 for (int i = capacity; i < newCapacity; i++)
                     elements[i] = b;

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java	Sat Jan 17 13:56:59 2009
@@ -327,14 +327,15 @@
                                    LispObject initialContents)
     throws ConditionThrowable
   {
-    if (initialContents != NIL)
+    if (initialContents != null)
       return new SimpleArray_T(dimv, elementType, initialContents);
     for (int i = 0; i < dimv.length; i++)
       {
         if (dimv[i] != this.dimv[i])
           {
             SimpleArray_T newArray = new SimpleArray_T(dimv, elementType);
-            newArray.fill(initialElement);
+            if (initialElement != null)
+                newArray.fill(initialElement);
             copyArray(this, newArray);
             return newArray;
           }

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java	Sat Jan 17 13:56:59 2009
@@ -303,13 +303,14 @@
                                      LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL)
+        if (initialContents != null)
             return new SimpleArray_UnsignedByte16(dimv, initialContents);
         for (int i = 0; i < dimv.length; i++) {
             if (dimv[i] != this.dimv[i]) {
                 SimpleArray_UnsignedByte16 newArray =
                     new SimpleArray_UnsignedByte16(dimv);
-                newArray.fill(initialElement);
+                if (initialElement != null)
+                    newArray.fill(initialElement);
                 copyArray(this, newArray);
                 return newArray;
             }

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java	Sat Jan 17 13:56:59 2009
@@ -293,13 +293,14 @@
                                      LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL)
+        if (initialContents != null)
             return new SimpleArray_UnsignedByte32(dimv, initialContents);
         for (int i = 0; i < dimv.length; i++) {
             if (dimv[i] != this.dimv[i]) {
                 SimpleArray_UnsignedByte32 newArray =
                     new SimpleArray_UnsignedByte32(dimv);
-                newArray.fill(initialElement);
+                if (initialElement != null)
+                    newArray.fill(initialElement);
                 copyArray(this, newArray);
                 return newArray;
             }

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java	Sat Jan 17 13:56:59 2009
@@ -290,13 +290,14 @@
                                      LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL)
+        if (initialContents != null)
             return new SimpleArray_UnsignedByte8(dimv, initialContents);
         for (int i = 0; i < dimv.length; i++) {
             if (dimv[i] != this.dimv[i]) {
                 SimpleArray_UnsignedByte8 newArray =
                     new SimpleArray_UnsignedByte8(dimv);
-                newArray.fill(initialElement);
+                if (initialElement != null)
+                    newArray.fill(initialElement);
                 copyArray(this, newArray);
                 return newArray;
             }

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleBitVector.java	Sat Jan 17 13:56:59 2009
@@ -199,7 +199,7 @@
                                        LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL) {
+        if (initialContents != null) {
             SimpleBitVector v = new SimpleBitVector(newCapacity);
             if (initialContents.listp()) {
                 LispObject list = initialContents;
@@ -223,7 +223,7 @@
                 else
                     v.clearBit(i);
             }
-            if (initialElement != NIL && capacity < newCapacity) {
+            if (initialElement != null && capacity < newCapacity) {
                 int n = Fixnum.getValue(initialElement);
                 if (n == 1)
                     for (int i = capacity; i < newCapacity; i++)

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleString.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleString.java	Sat Jan 17 13:56:59 2009
@@ -465,7 +465,7 @@
                                        LispObject initialContents)
         throws ConditionThrowable
     {
-        if (initialContents != NIL) {
+        if (initialContents != null) {
             char[] newChars = new char[newCapacity];
             if (initialContents.listp()) {
                 LispObject list = initialContents;
@@ -483,7 +483,7 @@
         if (capacity != newCapacity) {
             char[] newChars = new char[newCapacity];
             System.arraycopy(chars, 0, newChars, 0, Math.min(newCapacity, capacity));
-            if (initialElement != NIL && capacity < newCapacity) {
+            if (initialElement != null && capacity < newCapacity) {
                 final char c = LispCharacter.getValue(initialElement);
                 for (int i = capacity; i < newCapacity; i++)
                     newChars[i] = c;

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleVector.java	Sat Jan 17 13:56:59 2009
@@ -336,7 +336,7 @@
                                      LispObject initialContents)
     throws ConditionThrowable
   {
-    if (initialContents != NIL)
+    if (initialContents != null)
       {
         LispObject[] newData = new LispObject[newCapacity];
         if (initialContents.listp())
@@ -362,8 +362,9 @@
         LispObject[] newData = new LispObject[newCapacity];
         System.arraycopy(data, 0, newData, 0,
                          Math.min(capacity, newCapacity));
-        for (int i = capacity; i < newCapacity; i++)
-          newData[i] = initialElement;
+        if (initialElement != null)
+            for (int i = capacity; i < newCapacity; i++)
+                newData[i] = initialElement;
         return new SimpleVector(newData);
       }
     // No change.

Modified: trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java	Sat Jan 17 13:56:59 2009
@@ -169,15 +169,15 @@
                                               LispObject initialContents)
     throws ConditionThrowable {
       if (isAdjustable()) {
-          if (initialContents != NIL)
+          // initial element doesn't matter:
+          // we're not creating new elements
+          if (initialContents != null)
               data = initialContents;
-          else
-              data = initialElement;
           return this;
       } else {
           return new ZeroRankArray(elementType,
-                  initialContents != NIL ? initialContents : initialElement,
-                  false);
+                  initialContents != null ? initialContents :
+                      initialElement != null ? initialElement : data, false);
       }
   }
 

Modified: trunk/abcl/src/org/armedbear/lisp/adjust_array.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/adjust_array.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/adjust_array.java	Sat Jan 17 13:56:59 2009
@@ -51,14 +51,14 @@
         AbstractArray array = checkArray(args[0]);
         LispObject dimensions = args[1];
         LispObject elementType = args[2];
-        LispObject initialElement = args[3];
-        LispObject initialElementProvided = args[4];
-        LispObject initialContents = args[5];
-        LispObject initialContentsProvided = args[6];
+        boolean initialElementProvided = args[4] != NIL;
+        boolean initialContentsProvided = args[6] != NIL;
+        LispObject initialElement = initialElementProvided ? args[3] : null;
+        LispObject initialContents = initialContentsProvided ? args[5] : null;
         LispObject fillPointer = args[7];
         LispObject displacedTo = args[8];
         LispObject displacedIndexOffset = args[9];
-        if (initialElementProvided != NIL && initialContentsProvided != NIL) {
+        if (initialElementProvided && initialContentsProvided) {
             return error(new LispError("ADJUST-ARRAY: cannot specify both initial element and initial contents."));
         }
         if (elementType != array.getElementType() &&
@@ -67,10 +67,9 @@
             return error(new LispError("ADJUST-ARRAY: incompatible element type."));
         }
         if (array.getRank() == 0) {
-            return array.adjustArray(new int[0], NIL,
-                    (initialContentsProvided != NIL) ? initialContents : initialElement);
+            return array.adjustArray(new int[0], initialElement, initialContents);
         }
-        if (initialElementProvided == NIL && array.getElementType() == T)
+        if (!initialElementProvided && array.getElementType() == T)
             initialElement = Fixnum.ZERO;
         if (array.getRank() == 1) {
             final int newSize;



From mevenson at common-lisp.net  Sun Jan 18 10:51:09 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 18 Jan 2009 10:51:09 +0000
Subject: [armedbear-cvs] r11563 - in trunk/abcl/test/lisp: . abcl cl-bench
Message-ID: <E1LOVFF-0006rN-Td@common-lisp.net>

Author: mevenson
Date: Sun Jan 18 10:51:05 2009
New Revision: 11563

Log:
Arrangin directory structure for Lisp-based test suites.



Added:
   trunk/abcl/test/lisp/abcl/
   trunk/abcl/test/lisp/cl-bench/cl-bench.asd
      - copied unchanged from r11562, /trunk/abcl/test/lisp/cl-bench.asd
Removed:
   trunk/abcl/test/lisp/cl-bench.asd



From ehuelsmann at common-lisp.net  Sun Jan 18 18:34:54 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 18 Jan 2009 18:34:54 +0000
Subject: [armedbear-cvs] r11564 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOcU2-0002Hz-LT@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 18 18:34:53 2009
New Revision: 11564

Log:
Fix compiler issue found by compiling AP5: Instead of calculating the true upper bound
(which may become a number as big as 2^most-positive-fixnum), return '* as the upper bound
instead. The number won't fit into a fixnum anyway.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan 18 18:34:53 2009
@@ -6139,7 +6139,8 @@
 	      ;; Everything is non-negative.
 	      (setf result-type (list 'INTEGER
 				      (ash low1 low2)
-				      (ash high1 high2))))
+                                      (if (<= 64 high2)
+                                          '* (ash high1 high2)))))
 	     ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
 	      ;; Negative (or zero) second argument.
 	      (setf result-type (list 'INTEGER



From ehuelsmann at common-lisp.net  Sun Jan 18 19:39:48 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 18 Jan 2009 19:39:48 +0000
Subject: [armedbear-cvs] r11565 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOdUq-0004mE-BU@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 18 19:39:47 2009
New Revision: 11565

Log:
Fix thinko: it's not "unless", it's "when" ext:*inspector-hook* is bound to a non-NIL value.

Modified:
   trunk/abcl/src/org/armedbear/lisp/inspect.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/inspect.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/inspect.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/inspect.lisp	Sun Jan 18 19:39:47 2009
@@ -139,7 +139,7 @@
       (format t "No object is being inspected.")))
 
 (defun inspect (obj)
-  (unless ext:*inspector-hook*
+  (when ext:*inspector-hook*
     (funcall ext:*inspector-hook* obj))
   (when *inspected-object*
     (push *inspected-object* *inspected-object-stack*))



From ehuelsmann at common-lisp.net  Sun Jan 18 21:04:08 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 18 Jan 2009 21:04:08 +0000
Subject: [armedbear-cvs] r11566 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOeoS-0000JY-8v@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 18 21:04:07 2009
New Revision: 11566

Log:
Make sure to dump all floats with exponent marker, because when loaded, the default may differ.

Modified:
   trunk/abcl/src/org/armedbear/lisp/dump-form.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/dump-form.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/dump-form.lisp	Sun Jan 18 21:04:07 2009
@@ -112,7 +112,10 @@
         (*print-level* nil)
         (*print-length* nil)
         (*print-circle* nil)
-        (*print-structure* t))
+        (*print-structure* t)
+        ;; make sure to write all floats with their exponent marker:
+        ;; the dump-time default may not be the same at load-time
+        (*read-default-float-format* nil))
     (dump-object form stream)))
 
 (provide 'dump-form)



From ehuelsmann at common-lisp.net  Sun Jan 18 21:06:28 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 18 Jan 2009 21:06:28 +0000
Subject: [armedbear-cvs] r11567 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOeqi-0000Lc-4z@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 18 21:06:27 2009
New Revision: 11567

Log:
Use the same lines as in SBCL to make sure SCALE-EXPONENT works for all float types.

Modified:
   trunk/abcl/src/org/armedbear/lisp/format.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/format.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/format.lisp	Sun Jan 18 21:06:27 2009
@@ -252,6 +252,11 @@
              (incf index))
            (concatenate 'string (subseq s 0 index) "." (subseq s index))))))
 
+
+(eval-when (:compile-toplevel :execute)
+    ;; the code below needs to its floats to be read as long-floats
+    (setf *read-default-float-format* 'double-float))
+
 (defun scale-exponent (original-x)
   (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent) (decode-float x)



From ehuelsmann at common-lisp.net  Sun Jan 18 22:14:51 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 18 Jan 2009 22:14:51 +0000
Subject: [armedbear-cvs] r11568 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOfut-0003Rf-KK@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 18 22:14:51 2009
New Revision: 11568

Log:
Restore *read-base* and *read-default-float-format* after compiling a file.

They could have been changed (and in our case the latter *is*) during file compilation.


Modified:
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Sun Jan 18 22:14:51 2009
@@ -418,6 +418,8 @@
         (with-compilation-unit ()
           (with-open-file (out temp-file :direction :output :if-exists :supersede)
             (let ((*readtable* *readtable*)
+                  (*read-default-float-format* *read-default-float-format*)
+                  (*read-base* *read-base*)
                   (*package* *package*)
                   (*speed* *speed*)
                   (*space* *space*)



From ehuelsmann at common-lisp.net  Mon Jan 19 09:36:19 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 19 Jan 2009 09:36:19 +0000
Subject: [armedbear-cvs] r11569 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LOqYM-00066N-BD@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 19 09:36:06 2009
New Revision: 11569

Log:
Eliminate float-serializing ambiguities: if you need a float/double, store one
(instead of reading it from a string).

Modified:
   trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java	Mon Jan 19 09:36:06 2009
@@ -33,6 +33,8 @@
 
 package org.armedbear.lisp;
 
+import java.math.BigInteger;
+
 public final class FloatFunctions extends Lisp
 {
     // ### set-floating-point-modes &key traps => <no values>
@@ -142,6 +144,27 @@
         }
     };
 
+    // ### %float-bits float => integer
+    private static final Primitive _FLOAT_BITS =
+        new Primitive("%float-bits", "integer")
+    {
+        @Override
+        public LispObject execute(LispObject arg) throws ConditionThrowable
+        {
+            if (arg instanceof SingleFloat) {
+                int bits = Float.floatToIntBits(((SingleFloat)arg).value);
+                BigInteger big = BigInteger.valueOf(bits >> 1);
+                return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
+            }
+            if (arg instanceof DoubleFloat) {
+                long bits = Double.doubleToLongBits(((DoubleFloat)arg).value);
+                BigInteger big = BigInteger.valueOf(bits >> 1);
+                return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
+            }
+            return type_error(arg, Symbol.FLOAT);
+        }
+    };
+
     // ### rational
     private static final Primitive RATIONAL =
         new Primitive("rational", "number")

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Jan 19 09:36:06 2009
@@ -129,6 +129,11 @@
   (declare (optimize speed))
   (pool-get (list 3 n)))
 
+(defknown pool-float (single-float) (integer 1 65535))
+(defun pool-float (n)
+  (declare (optimize speed))
+  (pool-get (list 4 (%float-bits n))))
+
 (defknown pool-long (integer) (integer 1 65535))
 (defun pool-long (n)
   (declare (optimize speed))
@@ -152,6 +157,29 @@
       (setf *pool-count* (+ index 2)))
     index))
 
+(defknown pool-double (double-float) (integer 1 65535))
+(defun pool-double (n)
+  (declare (optimize speed))
+  (let* ((n (%float-bits n))
+         (entry (list 6
+                      (logand (ash n -32) #xffffffff)
+                      (logand n #xffffffff)))
+         (ht *pool-entries*)
+         (index (gethash1 entry ht)))
+    (declare (type hash-table ht))
+    (unless index
+      (setf index *pool-count*)
+      (push entry *pool*)
+      (setf (gethash entry ht) index)
+      ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte
+      ;; constants take up two entries in the constant_pool table of the class
+      ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the
+      ;; item in the constant_pool table at index n, then the next usable item in
+      ;; the pool is located at index n+2. The constant_pool index n+1 must be
+      ;; valid but is considered unusable." So:
+      (setf *pool-count* (+ index 2)))
+    index))
+
 (defknown u2 (fixnum) cons)
 (defun u2 (n)
   (declare (optimize speed))
@@ -199,6 +227,10 @@
 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
 (defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum")
 (defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;")
+(defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat")
+(defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;")
+(defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat")
+(defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;")
 (defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter")
 (defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;")
 (defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;")
@@ -1553,14 +1585,14 @@
   (declare (optimize speed))
   (declare (type (unsigned-byte 16) n))
   (declare (type stream stream))
-  (write-8-bits (ash n -8) stream)
+  (write-8-bits (logand (ash n -8) #xFF) stream)
   (write-8-bits (logand n #xFF) stream))
 
 (defknown write-u4 (integer stream) t)
 (defun write-u4 (n stream)
   (declare (optimize speed))
   (declare (type (unsigned-byte 32) n))
-  (write-u2 (ash n -16) stream)
+  (write-u2 (logand (ash n -16) #xFFFF) stream)
   (write-u2 (logand n #xFFFF) stream))
 
 (declaim (ftype (function (t t) t) write-s4))
@@ -1630,15 +1662,15 @@
     (case tag
       (1 ; UTF8
        (write-utf8 (third entry) stream))
-      (3 ; int
-       (write-s4 (second entry) stream))
-      ((5 6)
+      ((3 4) ; int
+       (write-u4 (second entry) stream))
+      ((5 6) ; long double
        (write-u4 (second entry) stream)
        (write-u4 (third entry) stream))
-      ((9 10 11 12)
+      ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType
        (write-u2 (second entry) stream)
        (write-u2 (third entry) stream))
-      ((7 8)
+      ((7 8) ; class string
        (write-u2 (second entry) stream))
       (t
        (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))
@@ -2014,6 +2046,36 @@
 	    (setf *static-code* *code*))))
    (setf (gethash n ht) g)))
 
+(defknown declare-float (single-float) string)
+(defun declare-float (s)
+  (declare-with-hashtable
+   s *declared-floats* ht g
+   (let* ((*code* *static-code*))
+     (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym))))
+     (declare-field g +lisp-single-float+)
+     (emit 'new +lisp-single-float-class+)
+     (emit 'dup)
+     (emit 'ldc (pool-float s))
+     (emit-invokespecial-init +lisp-single-float-class+ '("F"))
+     (emit 'putstatic *this-class* g +lisp-single-float+)
+     (setf *static-code* *code*))
+   (setf (gethash s ht) g)))
+
+(defknown declare-double (double-float) string)
+(defun declare-double (d)
+  (declare-with-hashtable
+   d *declared-doubles* ht g
+   (let ((*code* *static-code*))
+     (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym))))
+     (declare-field g +lisp-double-float+)
+     (emit 'new +lisp-double-float-class+)
+     (emit 'dup)
+     (emit 'ldc2_w (pool-double d))
+     (emit-invokespecial-init +lisp-double-float-class+ '("D"))
+     (emit 'putstatic *this-class* g +lisp-double-float+)
+     (setf *static-code* *code*))
+   (setf (gethash d ht) g)))
+
 (defknown declare-character (t) string)
 (defun declare-character (c)
   (let ((g (symbol-name (gensym)))
@@ -2201,6 +2263,12 @@
         ((integerp form)
          ;; A bignum.
          (emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+))
+        ((typep form 'single-float)
+         (emit 'getstatic *this-class*
+               (declare-float form) +lisp-single-float+))
+        ((typep form 'double-float)
+         (emit 'getstatic *this-class*
+               (declare-double form) +lisp-double-float+))
         ((numberp form)
          ;; A number, but not a fixnum.
          (emit 'getstatic *this-class*

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Jan 19 09:36:06 2009
@@ -85,6 +85,8 @@
 (defvar *declared-functions* nil)
 (defvar *declared-strings* nil)
 (defvar *declared-integers* nil)
+(defvar *declared-floats* nil)
+(defvar *declared-doubles* nil)
 
 (defstruct (class-file (:constructor %make-class-file))
   pathname ; pathname of output file
@@ -101,7 +103,9 @@
   (symbols (make-hash-table :test 'eq))
   (functions (make-hash-table :test 'equal))
   (strings (make-hash-table :test 'eq))
-  (integers (make-hash-table :test 'eql)))
+  (integers (make-hash-table :test 'eql))
+  (floats (make-hash-table :test 'eql))
+  (doubles (make-hash-table :test 'eql)))
 
 (defun class-name-from-filespec (filespec)
   (let* ((name (pathname-name filespec)))
@@ -131,7 +135,9 @@
             (*declared-symbols*   (class-file-symbols ,var))
             (*declared-functions* (class-file-functions ,var))
             (*declared-strings*   (class-file-strings ,var))
-            (*declared-integers*  (class-file-integers ,var)))
+            (*declared-integers*  (class-file-integers ,var))
+            (*declared-floats*    (class-file-floats ,var))
+            (*declared-doubles*   (class-file-doubles ,var)))
        (progn , at body)
        (setf (class-file-pool ,var)         *pool*
              (class-file-pool-count ,var)   *pool-count*
@@ -141,7 +147,9 @@
              (class-file-symbols ,var)      *declared-symbols*
              (class-file-functions ,var)    *declared-functions*
              (class-file-strings ,var)      *declared-strings*
-             (class-file-integers ,var)     *declared-integers*))))
+             (class-file-integers ,var)     *declared-integers*
+             (class-file-floats ,var)       *declared-floats*
+             (class-file-doubles ,var)      *declared-doubles*))))
 
 (defstruct compiland
   name



From mevenson at common-lisp.net  Mon Jan 19 14:12:11 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Mon, 19 Jan 2009 14:12:11 +0000
Subject: [armedbear-cvs] r11570 - trunk/abcl
Message-ID: <E1LOurL-0001pF-Ir@common-lisp.net>

Author: mevenson
Date: Mon Jan 19 14:12:06 2009
New Revision: 11570

Log:
Refactored Ant-based build to decrease compilation time.

<antcall> targets are *always* invoked, so refactoring these out them
enables 'abcl.stamp' to not doubly invoke compile.lisp.

Remove odd references to J.  

'abcl.init' replaces 'abcl.pre-compile' for aesthetic reasons.




Modified:
   trunk/abcl/build.xml

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Mon Jan 19 14:12:06 2009
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <project xmlns="antlib:org.apache.tools.ant"
 	 name="abcl-master" default="help" basedir=".">
-    <description>Armed Bear Common Lisp</description>
+    <description>Compiling, testing, and packaging Armed Bear Common Lisp</description>
 
     <target name="abcl" depends="abcl.wrapper"/>
 
@@ -20,7 +20,6 @@
     <property name="abcl.ext.dir"
 	      value="${basedir}/ext"/>
 
-
     <target name="help">
       <echo>Main Ant targets:
  abcl.compile  
@@ -38,58 +37,6 @@
       <echo>Corresponding targets for J have been removed.</echo>
     </target>
 
-    <property name="abcl.version.path"
-	      value="${build.classes.dir}/org/armedbear/lisp/version"/>
-    <property name="abcl.build.path"
-	      value="${build.classes.dir}/org/armedbear/lisp/build"/>
-
-    <target name="abcl.stamp" depends="abcl.compile">
-      <tstamp>
-         <format property="build" pattern="EEE MMM dd yyyy HH:mm:ss zzz"/>
-      </tstamp>
-      <mkdir dir="${abcl.build.path}/.."/>
-      <echo message="${build}" file="${abcl.build.path}"/>    
-      <condition property="unix"> 
-	<or>
-	  <os family="unix"/>
-	  <os family="mac"/>
-	</or>
-      </condition>
-
-      <condition property="windows"> <os family="windows"/></condition>
-
-      <available file="${src.dir}org/armedbear/lisp/Interpreter.java" 
-		 property="abcl.lisp.p"/>
-
-      <antcall target="abcl.stamp.version"/>
-      <antcall target="abcl.stamp.hostname"/>
-    </target>
-
-    <target name="abcl.stamp.version" depends="abcl.compile">
-      <java fork="true"
-	    classpath="${build.classes.dir}"
-	    outputproperty="abcl.version"
-	    classname="org.armedbear.lisp.Main">
-	<arg value="--noinit"/>
-	<arg value="--noinform"/>
-	<arg value="--eval"/>
-	<arg value="(progn (format t (lisp-implementation-version)) (finish-output) (quit))"/>
-      </java>
-
-      <echo>Building ABCL version: ${abcl.version}</echo>
-      <mkdir dir="${abcl.version.path}/.."/>
-      <echo message="${abcl.version}" file="${abcl.version.path}"/> 
-
-      <!-- Set from commandline via -D or in 'build.properties' -->
-      <property name="build.version" value="abcl.svn"/>
-      <echo>Implementation-Source: ${version.src}</echo>
-    </target>
-
-    <target name="abcl.stamp.hostname">
-      <exec executable="hostname" outputproperty="abcl.hostname"/>
-      <echo>abcl.hostname: ${abcl.hostname}</echo>
-    </target>
-
     <patternset id="abcl.source.java">
       <include name="org/armedbear/lisp/*.java"/>
       <include name="org/armedbear/lisp/util/*.java"/>
@@ -98,6 +45,7 @@
     <patternset id="abcl.source.lisp">
       <include name="org/armedbear/lisp/*.lisp"/>
       <include name="org/armedbear/lisp/tests/*.lisp"/>
+      <exclude name="org/armedbear/lisp/j.lisp"/>
     </patternset>
 
     <patternset id="abcl.scripting.source.java">
@@ -130,49 +78,59 @@
       <pathelement location="${build.classes.dir}"/>
     </path>
 
-    <target name="abcl.compile" depends="abcl.pre-compile,abcl.compile.lisp">
-      <echo>Compiled ABCL with java version: ${java.version}</echo>
+    <target name="abcl.compile" depends="abcl.compile.lisp">
+      <echo>Compiled ABCL with Java version: ${java.version}</echo>
     </target>
 
-    <target name="abcl.pre-compile">
+    <target name="abcl.init">
+      <tstamp>
+	<format property="build" pattern="EEE MMM dd yyyy HH:mm:ss zzz"/>
+      </tstamp>
+
       <!--- antversion fails in ant 1.7.1 <antversion property="ant.version" 
 	                                              atleast="1.7"/> -->
-      <mkdir dir="${build.dir}"/>
-      <mkdir dir="${build.classes.dir}"/>
-
       <property name="java.path"
 		value="${java.home}/bin/java"/>
 
-      <exec executable="hostname" os="unix" 
-	    outputproperty="abcl.compile.hostname"/>
-      <exec executable="uname" os="unix" 
-	    outputproperty="abcl.compile.uname">
-	<arg value="-a"/>
-      </exec>
+      <!-- Deprecated. Two main types of build environents: 'unix' or 'windows'. -->
+      <condition property="unix"> 
+	<or>
+	  <os family="unix"/>
+	  <os family="mac"/>
+	</or>
+      </condition>
+      <condition property="windows"> 
+	<os family="windows"/>
+      </condition>
 
-      <exec executable="hostname" os="Linux" outputproperty="hostname"/>
+      <!-- Deprecated. -->
+      <available file="${src.dir}org/armedbear/lisp/Interpreter.java" 
+		 property="abcl.lisp.p"/>
 
-      <condition property="abcl.java.version">
+      <echo>java.version: ${java.version}</echo>
+      <condition property="abcl.java.version.p">
 	<or>
 	  <matches string="${java.version}" pattern="1\.5"/>
 	  <matches string="${java.version}" pattern="1\.6\.0_1[0-9]"/>
 	</or>  
       </condition>
-      <echo>java.version: ${java.version}</echo>
+
+      <!-- Set from commandline via -D or in 'build.properties' -->
+      <property name="build.version" value="abcl.svn"/>
+      <echo>Implementation-Source: ${version.src}</echo>
+
     </target>
     
     <target name="abcl.java.warning" 
-	    depends="abcl.pre-compile"
-	    unless="abcl.java.version">
-      <echo>WARNING: Java version ${java.version} not recommended.</echo>
+	    depends="abcl.init"
+	    unless="abcl.java.version.p">
+      <echo>WARNING: Use of Java version ${java.version} not recommended.</echo>
     </target>
 	
     <target name="abcl.compile.java" 
-	    depends="abcl.pre-compile,abcl.java.warning">
-      <tstamp>
-	<format property="build" pattern="EEE MMM dd yyyy HH:mm:ss zzz"/>
-      </tstamp>
-
+	    depends="abcl.init,abcl.java.warning">
+      <mkdir dir="${build.dir}"/>
+      <mkdir dir="${build.classes.dir}"/>
       <javac destdir="${build.classes.dir}"
 	     debug="true"
 	     target="1.5">
@@ -193,7 +151,8 @@
 
     <!-- Adjust the patternset for ABCL source to use the much faster
          Ant 'uptodate' task to check if we need to compile the system
-         fasls. -->
+         fasls.  Highly inter-dependent with the behavior specified in
+         'compile-system.lisp'.-->
     <patternset id="abcl.source.lisp.fasls">
       <patternset refid="abcl.source.lisp"/>
       <exclude name="org/armedbear/lisp/tests/*.lisp"/>
@@ -224,7 +183,39 @@
       </java>
     </target>
 
-    <target name="abcl.jar" depends="abcl.compile,abcl.stamp">
+    <property name="abcl.build.path"
+	      value="${build.classes.dir}/org/armedbear/lisp/build"/>
+    <target name="abcl.stamp" depends="abcl.compile,abcl.stamp.version,abcl.stamp.hostname">
+      <mkdir dir="${abcl.build.path}/.."/>
+      <echo message="${build}" file="${abcl.build.path}"/>    
+    </target>
+
+    <property name="abcl.version.path"
+	      value="${build.classes.dir}/org/armedbear/lisp/version"/>
+    <target name="abcl.stamp.version" depends="abcl.compile">
+      <!-- Determine which ABCL version we have just built by parsing
+           the output of LISP-IMPLEMENTATION-VERSION. -->
+      <java fork="true"
+	    classpath="${build.classes.dir}"
+	    outputproperty="abcl.version"
+	    classname="org.armedbear.lisp.Main">
+	<arg value="--noinit"/>
+	<arg value="--noinform"/>
+	<arg value="--eval"/>
+	<arg value="(progn (format t (lisp-implementation-version)) (finish-output) (quit))"/>
+      </java>
+
+      <echo>Built ABCL version: ${abcl.version}</echo>
+      <mkdir dir="${abcl.version.path}/.."/>
+      <echo message="${abcl.version}" file="${abcl.version.path}"/> 
+    </target>
+
+    <target name="abcl.stamp.hostname" if="unix">
+      <exec executable="hostname" outputproperty="abcl.hostname"/>
+      <echo>abcl.hostname: ${abcl.hostname}</echo>
+    </target>
+
+    <target name="abcl.jar" depends="abcl.stamp">
       <mkdir dir="${dist.dir}"/>
       <loadfile property="abcl.version"
 		  srcFile="${abcl.version.path}"/>
@@ -241,30 +232,13 @@
 		       value="${abcl.version}"/>
 	    <attribute name="Implementation-Build" 
 		       value="${build}"/>
-	    <attribute name="Build-Version" 
-		       value="${version}"/>
+	    <attribute name="Implementation-Source" 
+		       value="${version.src}"/>
 	  </section>
 	</manifest>
       </jar>
     </target>
     
-    <target name="abcl.debug.jpda" depends="abcl.jar">
-      <description>Invoke ABCL with JPDA listener on port 6789</description>
-      <java fork="true"
-	    classpathref="abcl.classpath.dist"
-	    classname="org.armedbear.lisp.Main">
-	<jvmarg 
-	    value="-agentlib:jdwp=transport=dt_socket,address=6789,server=y"/>
-      </java>
-    </target>
-
-    <target name="abcl.run" depends="abcl.jar">
-      <java fork="true"
-	    classpathref="abcl.classpath.dist"
-	    classname="org.armedbear.lisp.Main">
-      </java>
-    </target>
-
     <target name="abcl.wrapper" 
 	    depends="abcl.jar,abcl.wrapper.unix,abcl.wrapper.windows">
       <description>
@@ -292,6 +266,8 @@
 	</filterset>
       </copy>
       <chmod file="${abcl.wrapper.file}" perm="a+x"/>
+
+      <echo>Created executable ABCL wrapper in '${abcl.wrapper.file}'</echo>
       <echo>N.B. This wrapper requires '${abcl.jar.path}' not be moved.</echo>
     </target>
 
@@ -305,9 +281,28 @@
       <property name="abcl.wrapper.in.file" value="abcl.bat.in"/>
     </target>
 
+    <target name="abcl.debug.jpda" depends="abcl.jar">
+      <description>Invoke ABCL with JPDA listener on port 6789</description>
+      <java fork="true"
+	    classpathref="abcl.classpath.dist"
+	    classname="org.armedbear.lisp.Main">
+	<jvmarg 
+	    value="-agentlib:jdwp=transport=dt_socket,address=6789,server=y"/>
+      </java>
+    </target>
+
+    <target name="abcl.run" depends="abcl.jar">
+      <java fork="true"
+	    classpathref="abcl.classpath.dist"
+	    classname="org.armedbear.lisp.Main">
+      </java>
+    </target>
+
     <target name="abcl.clean">
       <delete dir="${build.dir}"/>
+      <delete file="${abcl.jar.path}"/>
       <delete file="abcl"/>
+      <delete file="abcl.bat"/>
     </target>
 
     <target name="abcl.dist" depends="abcl.jar">
@@ -318,7 +313,7 @@
     <target name="abcl.distclean" depends="abcl.clean">
       <delete dir="${dist.dir}"/>
       <delete file="abcl"/>
-      <delete file="j"/>
+      <delete file="abcl.bat"/>
     </target>
 
     <target name="TAGS">
@@ -339,9 +334,9 @@
       <include name="abcl.in"/>
       <include name="abcl.bat.in"/>
       
-      <!-- The remainder of these files are used by BUILD-ABCL to
-           build ABCL from Lisp but not used by Ant, include them in
-           the source distribution. -->
+      <!-- The remainder of these files are used by the Lisp hosted
+           build in 'build-abcl.lisp' but not used by Ant, so include
+           them in the source distribution. -->
       <include name="make-jar.in"/>
       <include name="make-jar.bat.in"/>
 
@@ -360,7 +355,8 @@
     
     <target name="abcl.source.prepare" depends="abcl.stamp.version">
       <property name="abcl.source.eol" value="asis"/>
-      <echo>Using '${abcl.source.eol}' to drive line-ending transformations.</echo>
+      <echo>Using abcl.source.eol='${abcl.source.eol}' to drive
+      source code line-ending transformations.</echo>
       <property name="abcl.build.src.dir"
 		value="${build.dir}/abcl-src-${abcl.version}"/>
       <mkdir dir="${abcl.build.src.dir}/src"/>



From ehuelsmann at common-lisp.net  Mon Jan 19 20:30:03 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 19 Jan 2009 20:30:03 +0000
Subject: [armedbear-cvs] r11571 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LP0l1-0002GR-3W@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 19 20:29:38 2009
New Revision: 11571

Log:
Implement some building blocks for compilation of float math to byte code:
 - Constant compilation to specific representations
 - Boxing/unboxing of float/double values

See ticket #41.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Jan 19 20:29:38 2009
@@ -764,13 +764,30 @@
         ((eq required-representation :boolean)
          (emit-unbox-boolean))
         ((eq required-representation :long)
-         (emit-invokevirtual +lisp-object-class+ "longValue" nil "J"))))
+         (emit-invokevirtual +lisp-object-class+ "longValue" nil "J"))
+        ((eq required-representation :float)
+         (emit-invokevirtual +lisp-object-class+ "floatValue" nil "F"))
+        ((eq required-representation :double)
+         (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D"))
+        (t (assert nil))))
 
 (defknown emit-box-long () t)
 (defun emit-box-long ()
   (declare (optimize speed))
   (emit-invokestatic +lisp-class+ "number" '("J") +lisp-object+))
 
+(defknown emit-box-float () t)
+(defun emit-box-float ()
+  (emit 'new +lisp-single-float-class+)
+  (emit 'dup_x1)
+  (emit-invokespecial-init +lisp-single-float-class+ '("F")))
+
+(defknown emit-box-double () t)
+(defun emit-box-double ()
+  (emit 'new +lisp-double-float-class+)
+  (emit 'dup_x2)
+  (emit-invokespecial-init +lisp-double-float-class+ '("D")))
+
 (defknown convert-long (t) t)
 (defun convert-long (representation)
   (case representation
@@ -795,7 +812,11 @@
 (defun emit-move-from-stack (target &optional representation)
   (declare (optimize speed))
   (cond ((null target)
-         (emit 'pop))
+         (case representation
+           ((:long :double)
+            (emit 'pop2))
+           (t
+            (emit 'pop))))
         ((eq target 'stack)) ; Nothing to do.
         ((fixnump target)
          ;; A register.
@@ -805,6 +826,10 @@
              'istore)
             (:long
              'lstore)
+            (:float
+             'fstore)
+            (:double
+             'dstore)
             (t
              'astore))
           target))
@@ -2249,7 +2274,47 @@
     (:boolean
      (emit (if form 'iconst_1 'iconst_0))
      (emit-move-from-stack target representation)
-     (return-from compile-constant)))
+     (return-from compile-constant))
+    (:float
+     (cond ((fixnump form)
+            (compile-constant form 'stack :int)
+            (emit 'i2f))
+           ((and (integerp form)
+                 (<= most-negative-java-long form most-positive-java-long))
+            (compile-constant form 'stack :long)
+            (emit 'l2f))
+           ((integerp form)
+            (emit 'getfield *this-class* (declare-bignum form)
+                  +lisp-bignum+)
+            (emit-invokevirtual +lisp-bignum-class+ "floatValue" nil "F"))
+           ((typep form 'single-float)
+            (emit 'ldc (declare-float form)))
+           ((typep form 'double-float)
+            (emit 'ldc2_w (declare-double form))
+            (emit 'd2f))
+           (t (assert nil)))
+     (emit-move-from-stack target representation)
+     (return-from compile-constant))
+    (:double
+     (cond ((fixnump form)
+            (compile-constant form 'stack :int)
+            (emit 'i2d))
+           ((and (integerp form)
+                 (<= most-negative-java-long form most-positive-java-long))
+            (compile-constant form 'stack :long)
+            (emit 'l2d))
+           ((integerp form)
+            (emit 'getfield *this-class* (declare-bignum form)
+                  +lisp-bignum+)
+            (emit-invokevirtual +lisp-bignum-class+ "doubleValue" nil "D")
+           ((typep form 'single-float)
+            (emit 'ldc (declare-float form))
+            (emit 'f2d))
+           ((typep form 'double-float)
+            (emit 'ldc2_w (declare-double form)))
+           (t (assert nil)))
+     (emit-move-from-stack target representation)
+     (return-from compile-constant))))
   (cond ((fixnump form)
          (let ((translation (case form
                               (0  "ZERO")



From ehuelsmann at common-lisp.net  Wed Jan 21 21:25:21 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 21 Jan 2009 21:25:21 +0000
Subject: [armedbear-cvs] r11572 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LPkZd-0002dv-In@common-lisp.net>

Author: ehuelsmann
Date: Wed Jan 21 21:25:18 2009
New Revision: 11572

Log:
Fix NO-EXTRA-SYMBOLS-EXPORTED-FROM-COMMON-LISP.

Modified:
   trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java

Modified: trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java	Wed Jan 21 21:25:18 2009
@@ -146,7 +146,7 @@
 
     // ### %float-bits float => integer
     private static final Primitive _FLOAT_BITS =
-        new Primitive("%float-bits", "integer")
+        new Primitive("%float-bits", PACKAGE_SYS, true, "integer")
     {
         @Override
         public LispObject execute(LispObject arg) throws ConditionThrowable



From ehuelsmann at common-lisp.net  Wed Jan 21 22:14:49 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 21 Jan 2009 22:14:49 +0000
Subject: [armedbear-cvs] r11573 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LPlLV-0005TX-IZ@common-lisp.net>

Author: ehuelsmann
Date: Wed Jan 21 22:14:47 2009
New Revision: 11573

Log:
Add a 'getInstance' static method to all lisp classes which have a
compiler primitive for (part of) their domain.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Bignum.java
   trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java
   trunk/abcl/src/org/armedbear/lisp/LispCharacter.java
   trunk/abcl/src/org/armedbear/lisp/LispObject.java
   trunk/abcl/src/org/armedbear/lisp/SingleFloat.java

Modified: trunk/abcl/src/org/armedbear/lisp/Bignum.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Bignum.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Bignum.java	Wed Jan 21 22:14:47 2009
@@ -39,6 +39,13 @@
 {
   public final BigInteger value;
 
+  public static LispObject getInstance(long l) {
+      if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE)
+          return Fixnum.getInstance((int)l);
+      else
+          return new Bignum(l);
+  }
+
   public Bignum(long l)
   {
     value = BigInteger.valueOf(l);

Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java	Wed Jan 21 22:14:47 2009
@@ -53,6 +53,19 @@
         Symbol.DOUBLE_FLOAT_NEGATIVE_INFINITY.initializeConstant(DOUBLE_FLOAT_NEGATIVE_INFINITY);
     }
 
+    public static DoubleFloat getInstance(double d) {
+        if (d == 0)
+            return ZERO;
+        else if (d == -0.0d )
+            return MINUS_ZERO;
+        else if (d == 1)
+            return ONE;
+        else if (d == -1)
+            return MINUS_ONE;
+        else
+            return new DoubleFloat(d);
+    }
+
     public final double value;
 
     public DoubleFloat(double value)

Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java	Wed Jan 21 22:14:47 2009
@@ -288,7 +288,7 @@
           {
             String name = ((Symbol)arg).getName();
             if (name.length() == 1)
-              return getInstance(name.charAt(0));
+              return LispCharacter.getInstance(name.charAt(0));
           }
         return type_error(arg, Symbol.CHARACTER_DESIGNATOR);
       }
@@ -438,7 +438,7 @@
           }
         if (c < 128)
           return constants[LOWER_CASE_CHARS[c]];
-        return getInstance(toLowerCase(c));
+        return LispCharacter.getInstance(toLowerCase(c));
       }
     };
 
@@ -460,7 +460,7 @@
           }
         if (c < 128)
           return constants[UPPER_CASE_CHARS[c]];
-        return getInstance(toUpperCase(c));
+        return LispCharacter.getInstance(toUpperCase(c));
       }
     };
 

Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispObject.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispObject.java	Wed Jan 21 22:14:47 2009
@@ -40,6 +40,10 @@
     return T;
   }
 
+  static public LispObject getInstance(boolean b) {
+      return b ? T : NIL;
+  }
+
   public LispObject classOf()
   {
     return BuiltInClass.CLASS_T;

Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java	Wed Jan 21 22:14:47 2009
@@ -53,6 +53,19 @@
         Symbol.SINGLE_FLOAT_NEGATIVE_INFINITY.initializeConstant(SINGLE_FLOAT_NEGATIVE_INFINITY);
     }
 
+    public static SingleFloat getInstance(float f) {
+        if (f == 0)
+            return ZERO;
+        else if (f == -0.0f )
+            return MINUS_ZERO;
+        else if (f == 1)
+            return ONE;
+        else if (f == -1)
+            return MINUS_ONE;
+        else
+            return new SingleFloat(f);
+    }
+
     public final float value;
 
     public SingleFloat(float value)



From ehuelsmann at common-lisp.net  Wed Jan 21 22:35:45 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 21 Jan 2009 22:35:45 +0000
Subject: [armedbear-cvs] r11574 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LPlfl-0006bq-9W@common-lisp.net>

Author: ehuelsmann
Date: Wed Jan 21 22:35:44 2009
New Revision: 11574

Log:
Introduce LispInteger super-type to Bignum and Fixnum:
  The LispInteger logically can return both Bignum as well as Fixnum
values for its getInstance() method.

Added:
   trunk/abcl/src/org/armedbear/lisp/LispInteger.java
Modified:
   trunk/abcl/src/org/armedbear/lisp/Bignum.java
   trunk/abcl/src/org/armedbear/lisp/Fixnum.java

Modified: trunk/abcl/src/org/armedbear/lisp/Bignum.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Bignum.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Bignum.java	Wed Jan 21 22:35:44 2009
@@ -35,15 +35,12 @@
 
 import java.math.BigInteger;
 
-public final class Bignum extends LispObject
+public final class Bignum extends LispInteger
 {
   public final BigInteger value;
 
-  public static LispObject getInstance(long l) {
-      if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE)
-          return Fixnum.getInstance((int)l);
-      else
-          return new Bignum(l);
+  public static Bignum getInstance(long l) {
+    return new Bignum(l);
   }
 
   public Bignum(long l)

Modified: trunk/abcl/src/org/armedbear/lisp/Fixnum.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Fixnum.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Fixnum.java	Wed Jan 21 22:35:44 2009
@@ -35,7 +35,7 @@
 
 import java.math.BigInteger;
 
-public final class Fixnum extends LispObject
+public final class Fixnum extends LispInteger
 {
   public static final Fixnum[] constants = new Fixnum[256];
   static

Added: trunk/abcl/src/org/armedbear/lisp/LispInteger.java
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/LispInteger.java	Wed Jan 21 22:35:44 2009
@@ -0,0 +1,54 @@
+/*
+ * LispInteger.java
+ *
+ * Copyright (C) 2003-2007 Peter Graves
+ * $Id: Bignum.java 11573 2009-01-21 22:14:47Z ehuelsmann $
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module.  An independent module is a module which is not derived from
+ * or based on this library.  If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so.  If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package org.armedbear.lisp;
+
+/** This class merely serves as the super class for
+ * Fixnum and Bignum
+ */
+public class LispInteger extends LispObject
+{
+
+  public static LispInteger getInstance(long l) {
+      if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE)
+          return Fixnum.getInstance((int)l);
+      else
+          return new Bignum(l);
+  }
+
+  public static LispInteger getInstance(int i) {
+      return Fixnum.getInstance(i);
+  }
+
+
+}



From ehuelsmann at common-lisp.net  Thu Jan 22 20:00:52 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 22 Jan 2009 20:00:52 +0000
Subject: [armedbear-cvs] r11575 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQ5jQ-0005Yx-8B@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan 22 20:00:49 2009
New Revision: 11575

Log:
Eliminate the FastStringBuffer (from AbstractArray and AbstractBitVector).

Patch by: Philip Hudson

Note: In this category, more patches are expected.

Modified:
   trunk/abcl/src/org/armedbear/lisp/AbstractArray.java
   trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java

Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/AbstractArray.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/AbstractArray.java	Thu Jan 22 20:00:49 2009
@@ -142,13 +142,10 @@
     {
         final int rank = getRank();
         if (rank != subscripts.length) {
-            FastStringBuffer sb =
-                new FastStringBuffer("Wrong number of subscripts (");
-            sb.append(subscripts.length);
-            sb.append(") for array of rank ");
-            sb.append(rank);
-            sb.append('.');
-            error(new ProgramError(sb.toString()));
+            // ### i18n
+            final String errorMsg =
+                "Wrong number of subscripts (%d) for array of rank %d.";
+            error(new ProgramError(String.format(errorMsg, subscripts.length, rank)));
         }
         int sum = 0;
         int size = 1;
@@ -158,12 +155,10 @@
             size *= dim;
             final int n = subscripts[i];
             if (n < 0 || n >= dim) {
-                FastStringBuffer sb = new FastStringBuffer("Invalid index ");
-                sb.append(n);
-                sb.append(" for array ");
-                sb.append(writeToString());
-                sb.append('.');
-                error(new ProgramError(sb.toString()));
+                // ### i18n
+                final String errorMsg =
+                    "Invalid index %d for array %s.";
+                error(new ProgramError(String.format(errorMsg, n, writeToString())));
             }
             sum += n * lastSize;
         }
@@ -185,7 +180,7 @@
 
     public String writeToString(int[] dimv) throws ConditionThrowable
     {
-        FastStringBuffer sb = new FastStringBuffer();
+        StringBuilder sb = new StringBuilder();
         LispThread thread = LispThread.currentThread();
         LispObject printReadably = Symbol.PRINT_READABLY.symbolValue(thread);
         if (printReadably != NIL || Symbol.PRINT_ARRAY.symbolValue(thread) != NIL) {
@@ -232,7 +227,7 @@
     }
 
     // Helper for writeToString().
-    private void appendContents(int[] dimensions, int index, FastStringBuffer sb,
+    private void appendContents(int[] dimensions, int index, StringBuilder sb,
                                 LispThread thread)
         throws ConditionThrowable
     {
@@ -331,7 +326,7 @@
         throws ConditionThrowable;
 
     /**
-     * 
+     *
      * @param dims
      * @param displacedTo
      * @param displacement

Modified: trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java	Thu Jan 22 20:00:49 2009
@@ -185,19 +185,15 @@
         if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL ||
             Symbol.PRINT_ARRAY.symbolValue(thread) != NIL)
         {
-            FastStringBuffer sb = new FastStringBuffer(length + 2);
+            StringBuilder sb = new StringBuilder(length + 2);
             sb.append("#*");
             for (int i = 0; i < length; i++)
                 sb.append(getBit(i) == 1 ? '1' : '0');
             return sb.toString();
         } else {
-            FastStringBuffer sb = new FastStringBuffer("(");
-            if (this instanceof SimpleBitVector)
-                sb.append("SIMPLE-");
-            sb.append("BIT-VECTOR ");
-            sb.append(length);
-            sb.append(")");
-            return unreadableString(sb.toString());
+            final String str = "(%sBIT-VECTOR %d)";
+            final String pre = (this instanceof SimpleBitVector) ? "SIMPLE-" : "";
+            return unreadableString(String.format(str, pre, length));
         }
     }
 



From mevenson at common-lisp.net  Fri Jan 23 16:07:15 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Fri, 23 Jan 2009 16:07:15 +0000
Subject: [armedbear-cvs] r11576 - in trunk/abcl: .
	src/org/armedbear/lisp/tests test/lisp/abcl
Message-ID: <E1LQOYt-0008Vx-F4@common-lisp.net>

Author: mevenson
Date: Fri Jan 23 16:07:13 2009
New Revision: 11576

Log:
Move internal ABCL tests to proper hierarchy.

Loading via ASDF not finished.


Added:
   trunk/abcl/test/lisp/abcl/compiler-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/compiler-tests.lisp
   trunk/abcl/test/lisp/abcl/condition-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/condition-tests.lisp
   trunk/abcl/test/lisp/abcl/file-system-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/file-system-tests.lisp
   trunk/abcl/test/lisp/abcl/java-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/java-tests.lisp
   trunk/abcl/test/lisp/abcl/jl-config.cl
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/jl-config.cl
   trunk/abcl/test/lisp/abcl/math-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/math-tests.lisp
   trunk/abcl/test/lisp/abcl/misc-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/misc-tests.lisp
   trunk/abcl/test/lisp/abcl/pathname-tests.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/pathname-tests.lisp
   trunk/abcl/test/lisp/abcl/rt-package.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/rt-package.lisp
   trunk/abcl/test/lisp/abcl/rt.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/rt.lisp
   trunk/abcl/test/lisp/abcl/test-utilities.lisp
      - copied unchanged from r11562, /trunk/abcl/src/org/armedbear/lisp/tests/test-utilities.lisp
Removed:
   trunk/abcl/src/org/armedbear/lisp/tests/
Modified:
   trunk/abcl/abcl.asd

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Fri Jan 23 16:07:13 2009
@@ -35,6 +35,26 @@
 (defsystem :ansi-test-interpreted :version "0,1" :depends-on (ansi-test))
 (defsystem :ansi-test-compiled :version "0.1" :depends-on (ansi-test))
 
+
+(defsystem :abcl-tests
+  :version "1.0"
+  :components
+    ((:module rt :serial t  :pathname "test/lisp/abcl/" :components
+	      ((:file "rt-package") (:file "rt") (:file "test-utilities")))
+     (:module tests :depends-on (rt)
+	      :pathname "test/lisp/abcl/" :components
+	      ((:file "compiler-tests") 
+	       (:file "condition-tests")
+	       (:file "file-system-tests") 
+#+nil	       (:file "math-tests")
+	       (:file "java-tests")
+	       (:file "misc-tests")
+	       (:file "pathname-tests")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'abcl-tests))))
+  "Invoke tests with:  (asdf:operate 'asdf:test-op :abcl-tests)."
+  (funcall (intern (symbol-name 'do-tests) :test)))
+
 (defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-interpreted))))
   (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
 	   :compile-tests nil))



From vvoutilainen at common-lisp.net  Fri Jan 23 19:37:21 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Fri, 23 Jan 2009 19:37:21 +0000
Subject: [armedbear-cvs] r11577 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQRqD-00021S-5X@common-lisp.net>

Author: vvoutilainen
Date: Fri Jan 23 19:37:18 2009
New Revision: 11577

Log:
Support "partial" wildcards in DIRECTORY, like
 "/path/somewh*re/foo*.txt". This also makes cl-bench
report.lisp work with either CL*.* (the form in report.lisp)
or CL* (the form which is the only one that clisp works with).



Modified:
   trunk/abcl/src/org/armedbear/lisp/directory.lisp
   trunk/abcl/src/org/armedbear/lisp/pathnames.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/directory.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/directory.lisp	Fri Jan 23 19:37:18 2009
@@ -70,7 +70,8 @@
   (let ((pathname (merge-pathnames pathspec)))
     (when (logical-pathname-p pathname)
       (setq pathname (translate-logical-pathname pathname)))
-    (if (wild-pathname-p pathname)
+    (if (or (position #\* (namestring pathname))
+	    (wild-pathname-p pathname))
         (let ((namestring (directory-namestring pathname)))
           (when (and namestring (> (length namestring) 0))
             #+windows

Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/pathnames.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/pathnames.lisp	Fri Jan 23 19:37:18 2009
@@ -51,13 +51,46 @@
 (defun wild-pathname-p (pathname &optional field-key)
   (%wild-pathname-p pathname field-key))
 
+(defun component-match-wild-p (thing wild ignore-case)
+  (let ((testfunc (if ignore-case #'equalp #'equal)))
+    (labels ((split-string (delim str)
+	       (flet ((finder (char) (find char delim)))
+		 (loop  for x = (position-if-not #'finder str) then
+		      (position-if-not #'finder str :start (or y (length str)))
+		    for y = (position-if #'finder str :start x) then
+		      (position-if #'finder str :start (or x (length str))) while x 
+		    collect (subseq str x y))))
+	     (positions-larger (thing substrings previous-pos)
+	       (let ((new-pos (search (car substrings) 
+				      thing 
+				      :start2 previous-pos
+				      :test testfunc)))
+		 (or 
+		  (not substrings)
+		  (and new-pos
+		       (>= new-pos previous-pos)
+		       (positions-larger thing 
+					 (cdr substrings) 
+					 new-pos))))))
+      (let ((split-result (split-string "*" wild)))
+	(and (positions-larger thing split-result 0)
+	     (if (eql (elt wild 0) #\*)
+		 t
+		 (eql (search (first split-result) thing :test testfunc) 0))
+	     (if (eql (elt wild (1- (length wild))) #\*)
+		 t
+		 (let ((last-split-result (first (last split-result))))
+		   (eql (search last-split-result thing :from-end t 
+				:test testfunc)
+			(- (length thing) (length last-split-result))))))))))
+
 (defun component-match-p (thing wild ignore-case)
   (cond ((eq wild :wild)
          t)
         ((null wild)
          t)
         ((and (stringp wild) (position #\* wild))
-         (error "Unsupported wildcard pattern: ~S" wild))
+	 (component-match-wild-p thing wild ignore-case))
         (ignore-case
          (equalp thing wild))
         (t



From gking at common-lisp.net  Fri Jan 23 20:12:28 2009
From: gking at common-lisp.net (Lawrence Auster)
Date: Fri, 23 Jan 2009 21:12:28 +0100
Subject: [armedbear-cvs] Is Israel a Democracy? -- The problem with
 intellectually insecure whites -- Should Christians Support Israeli
 Terrorism in Gaza?
Message-ID: <20090123201240.JIYU128.aarprv06.charter.net@4k6l2>

The Jewish State of Israel has no constitution, nor does it name its borders. Israel's hidden constitution is Judaism. Israel's undeclared borders range from the Nile to the Euphrates rivers. Israel's desired jurisdiction extends over the entire Earth.

It could not be more clear that the Jewish State follows a foreign policy which obeys Jewish Law as iterated in the Hebrew Bible, the Talmud, Maimonedes, the Cabalah, and the many commentaries and refinements of same. The Jews are genociding the native inhabitants of Palestine, just as their religion advises, and because
their religion teaches them to do so. They treat non-Jews as if non-humans, just as their religion requires them to do. They make perpetual war on every nation on Earth, just as their genocidal Jewish God has instructed.

The Jews of Israel are simply being Jews. Jews are an existential threat to the human race.

Israel contains one third of the Jews of the World. It is not some aberration of the Jewish spirit, but the condensation and concentration of the perverse Jewish mentality, which malady also pervades the remaining two thirds of Jewry, who almost unanimously support the Jewish State, and who certainly do unanimously support
the Jewish People and its consistent and constant crimes against the human race. Israel is Jewry and the danger of Israel is the danger of the Jewish People to all others, as the Jews have demonstrated each and every day of their existence.

The Jews, the entire Jewish People of 15 million, will not relent until they have wiped out all non-Jews in "Greater Israel". They will not stop destroying all other cultures, nations, religions, ethnicities, races, competition, etc. until they are either stopped, or succeed in their ancient quest to destroy the human race.

What Israel is doing is not some reaction to outside forces, nor was the formation of Israel a response to the Holocaust. Israel is simply following the plan laid out in the Jews' religious texts. The Jews have openly planned to take Palestine and genocide the native population of Palestine for some 2,500 years before the
Holocaust. The Jews have openly complained that "anti-Semitism" is a threat that gives them the right to genocide the Palestinians, not merely since the advent of Nazism, but for some 2,500 years.

The Jewish religion is the Constitution of the Jewish State of Israel, and, to a greater or lesser extent, the constitution of the nature of every Jew alive. The borders of Israel are the range the Jew roams over the entire World. The perverse Jewish mentality is inbred by a Jew's exposure to his parents and to his community. Judaism
passes in the spit and slobber of Jewish mother telling her Jewish child that he is a "Jew", as much as Judaism passes in the poison and pain of a Talmudic tractate. The secular Jews did not suddenly come to life after the Enlightenment and the Jewish Reformation a body of vampires that appeared ex nihilo, in vacuo, mostly
atheistical and undetached from formally practiced Judaism. Judaism is the Jew. It is a mindset that transcends and supercedes religion. It is a belief set, a way of life, a perception of one's self and one's relation to the World that makes a Jew, a Jew, and a danger to all of humanity.

In fact, the religious shell of Judaism is like the stretched and infected skin of a lycanthropic pustule. When you lance it to cure the infection, the virus only becomes more contagious and spills directly on the non-Jew.

The secular Jew is a deliberate product of the hyper-religious Jew, a monster created out of the hewed corpses of the fanatically religious Jew, a Golem which is conjured up to enter the World of the non-Jew and poison its blood, and boil its brain with a rabid lunacy that bites and spreads, until the infected community feeds on
itself and fills the fields with rotting bloating bodies, where once human beings tilled the soil and tended to their families. The religious Jew created the secular Jew as an army of Esthers who seduce with open thighs, broad smiles, and a Siren call that lures in the non-Jew to cast his skull upon the jagged rocks and color the seas
with his blood, sickened and blinded by the venereal disease of Judaism in secular form.

Israel is not a secular democracy. It is a religious mockery. It is a rabid bat flying to the ends of the Earth, to end the Earth. No one will be free nor safe until the disease is quarantined and dies out.

Source: http://www.ziopedia.org/articles/israel/how_can_israel_claim_to_be_a_%27democracy%27_when_it_has_no_constitution_nor_borders?/`

--------------------

The problem with intellectually insecure whites
By Kevin MacDonald
January 19, 2009

America will soon have a white minority. This is a much desired state of affairs for the hostile elites who hold political power and shape public opinion. But it certainly creates some management issues ? at least in the long run. After all, it?s difficult to come up with an historical example of a nation with a solid ethnic majority (90%
white in 1950) that has voluntarily decided to cede political and cultural power. Such transformations are typically accomplished by military invasions, great battles, and untold suffering.

And it?s not as if everyone is doing it. Only Western nations view their own demographic and cultural eclipse as a moral imperative. Indeed, as I have noted previously, it is striking that racial nationalism has triumphed in Israel at the same time that the Jewish intellectual and political movements and the organized Jewish
community have been the most active and effective force for a non-white America. Indeed, a poll in 2008 found that Avigdor Lieberman was the second most popular politician in Israel. Lieberman has advocated expulsion of Arabs from Israel and has declared himself a follower of Vladimir Jabotinsky, the leading pioneer of racial
Zionism. The most popular politician in the poll was Benjamin Netanyahu ? another admirer of Jabotinsky. Prime Minister Ehud Olmert and Foreign Minister Tzipi Livni are also Jabotinskyists.

The racial Zionists are now carrying out yet another orgy of mass murder after a starvation-inducing blockade and the usual triggering assault designed to provoke Palestinian retaliation ? which then becomes the cover for claims that Israel is merely defending itself against terrorism. This monstrosity was approved by
overwhelming majorities of both Houses of Congress. The craven Bush administration did its part by abstaining from a UN resolution designed by the US Secretary of State as a result of a personal appeal by the Israeli Prime Minister. This is yet another accomplishment of the Israel Lobby, but one they would rather not have
discussed in public. People might get the impression that the Lobby really does dictate US foreign policy in the Mideast. Obviously, such thoughts are only entertained by anti-Semites.

But I digress.

In managing the eclipse of white America, one strategy of the mainstream media is to simply ignore the issue. Christopher Donovan  (?For the media, the less whites think about their coming minority status, the better?) has noted that the media, and in particular, the New York Times, are quite uninterested in doing stories that
discuss what white people think about this state of affairs.

It?s not surprising that the New York Times ? the Jewish-owned flagship of anti-white, pro-multicultural media ? ignores the issue. The issue is also missing from so-called conservative media even though one would think that conservatives would find the eclipse of white America to be an important issue. Certainly, their audiences
would find it interesting.

Now we have an article ?The End of White America? written by Hua Hsu, an Assistant Professor of English at Vassar College. The article is a rather depressing display of what passes for intellectual discourse on the most important question confronting white people in America.

Hsu begins by quoting a passage in F. Scott Fitzgerald?s The Great Gatsby in which a character, Tom Buchanan, states: ?Have you read The Rise of the Colored Empires by this man Goddard?? ? Well, it?s a fine book, and everybody ought to read it. The idea is if we don?t look out the white race will be?will be utterly submerged.
It?s all scientific stuff; it?s been proved.?

Buchanan?s comment is a thinly veiled reference to Lothrop Stoddard?s The Rising Tide of Color which Hsu describes as ?rationalized hatred? presented in a scholarly, gentlemanly, and scientific tone. (This wording that will certainly help him when he comes up for tenure.) As Hsu notes, Stoddard had a doctorate from Harvard
and was a member of many academic associations. His book was published by a major publisher. It was therefore ?precisely the kind of book that a 1920s man of Buchanan?s profile ? wealthy, Ivy League?educated, at once pretentious and intellectually insecure ? might have been expected to bring up in casual conversation.?

Let?s ponder that a bit. The simple reality is that in the year 2009 an Ivy League-educated person, "at once pretentious and intellectually insecure,"  would just as glibly assert the same sort of nonsense as Hsu. To wit:

The coming white minority does not mean that the racial hierarchy of American culture will suddenly become inverted, as in 1995?s White Man?s Burden, an awful thought experiment of a film, starring John Travolta, that envisions an upside-down world in which whites are subjugated to their high-class black oppressors. There will
be dislocations and resentments along the way, but the demographic shifts of the next 40 years are likely to reduce the power of racial hierarchies over everyone?s lives, producing a culture that?s more likely than any before to treat its inhabitants as individuals, rather than members of a caste or identity group.

The fact is that no one can say for certain what multicultural America without a white majority will be like. There is no scientific or historical basis for claims like ?the demographic shifts of the next 40 years are likely to reduce the power of racial hierarchies over everyone?s lives, producing a culture that?s more likely than any before
to treat its inhabitants as individuals, rather than members of a caste or identity group.?

Indeed, there is no evidence at all that we are proceeding to a color blind future. The election results continue to show that white people are coalescing in the Republican Party, while the Democrats are increasingly the party of a non-white soon-to-be majority.

Is it so hard to believe that when this coalition achieves a majority that it will further compromise the interests of whites far beyond contemporary concerns such as immigration policy and affirmative action? Hsu anticipates a colorblind world, but affirmative action means that blacks and other minorities are certainly not treated as
individuals. And it means that whites ? especially white males ? are losing out on opportunities they would have had without these policies and without the massive non-white immigration of the last few decades.

Given the intractability of changing intelligence and other traits required for success in the contemporary economy, it is unlikely that 40 more years of affirmative action will attain the outcomes desired by the minority lobbies. Indeed, in Obama's America, blacks are rioting in Oakland over perceived racial injustices, and from 2002
?2007, black juvenile homicide victims increased 31%, while black juvenile homicide perpetrators increased 43%. Hence,  the reasonable outlook is for a continuing need for affirmative action and for racial activism in these groups, even after whites become a minority.

Whites will also lose out because of large-scale importation of relatively talented immigrants from East Asia. Indeed, as I noted over a decade ago, "The United States is well on the road to being dominated by an Asian technocratic elite and a Jewish business, professional, and media elite."

Hsu shows that there already is considerable anxiety among whites about the future. An advertizing executive says, ?I think white people feel like they?re under siege right now ? like it?s not okay to be white right now, especially if you?re a white male. ... People are stressed out about it. ?We used to be in control! We?re losing
control?? Another says, "There?s a lot of fear and a lot of resentment."

It's hard to see why these feelings won't increase in the future.

A huge problem for white people is lack of intellectual and cultural confidence. Hsu quotes Christian (Stuff White People Like) Lander saying, "I get it: as a straight white male, I?m the worst thing on Earth." A professor comments that for his students "to be white is to be culturally broke. The classic thing white students say when
you ask them to talk about who they are is, ?I don?t have a culture.? They might be privileged, they might be loaded socioeconomically, but they feel bankrupt when it comes to culture ? They feel disadvantaged, and they feel marginalized."

This lack of cultural confidence is no accident. For nearly 100 years whites have been subjected to a culture of critique emanating from the most prestigious academic and media institutions. And, as Hsu points out, the most vibrant and influential aspect of American popular culture is hip-hop?a product of the African American
urban culture.

The only significant group of white people with any cultural confidence centers itself around country music, NASCAR, and the small town values of traditional white America. For this group of whites ? and only this group ? there is  "a racial pride that dares not speak its name, and that defines itself through cultural cues instead?a
suspicion of intellectual elites and city dwellers, a preference for folksiness and plainness of speech (whether real or feigned), and the association of a working-class white minority with 'the real America.'?

This is what I term implicit whiteness ? implicit because explicit assertions of white identity have been banned by the anti-white elites that dominate our politics and culture. It is a culture that, as Hsu notes, "cannot speak its name."

But that implies that the submerged white identity of the white working class and the lack of cultural confidence exhibited by the rest of white America are imposed from outside. Although there may well be characteristics of whites that facilitate this process, this suppression of white identity and interests is certainly not the natural
outcome of modernization or any other force internal to whites as a people. In my opinion, it is the result of the successful erection of a culture of critique in the West dominated by Jewish intellectual and political movements.

The result is that educated, intellectually insecure white people these days are far more likely to believe in the utopian future described by Hsu than in hard and cautious thinking about what the future might have in store for them.

It's worth dwelling a bit on the intellectual insecurity of the whites who mindlessly utter the mantras of multiculturalism that they have soaked up from the school system and from the media. Most people do not have much confidence in their intellectual ability and look to elite opinion to shape their beliefs. As I noted elsewhere,

A critical component of the success of the culture of critique is that it achieved control of the most prestigious and influential institutions of the West, and it became a consensus among the elites, Jewish and non-Jewish alike. Once this happened, it is not surprising that this culture became widely accepted among people of very
different levels of education and among people of different social classes.

Most people are quite insecure about their intellectual ability. But they know that the professors at Harvard, and the editorial page of the New York Times and the Washington Post, and even conservative commentators like Rush Limbaugh and Sean Hannity are all on page when it comes to racial and ethnic issues. This is a
formidable array, to the point that you almost have to be a crank to dissent from this consensus.

I think one of the greatest triumphs of the left has been to get people to believe that people who assert white identity and interests or who make unflattering portrayals of organized Jewish movements are morally degenerate, stupid, and perhaps psychiatrically disturbed. Obviously, all of these adjectives designate low status.

The reality is that the multicultural emperor has no clothes and, because of its support for racial Zionism and the racialism of ethnic minorities in America, it is massively hypocritical to boot. The New York Times, the academic left, and the faux conservatives that dominate elite discourse on race and ethnicity are intellectually
bankrupt and can only remain in power by ruthlessly suppressing or ignoring the scientific findings.

This is particularly a problem for college-educated whites. Like Fitzgerald's Tom Buchanan, such people have a strong need to feel that their ideas are respectable and part of the mainstream. But the respectable mainstream gives them absolutely nothing with which to validate themselves except perhaps the idea that the world
will be a better place when people like them no longer have power. Hsu quotes the pathetic Christian Lander: "?Like, I?m aware of all the horrible crimes that my demographic has done in the world. ... And there?s a bunch of white people who are desperate ? desperate ? to say, ?You know what? My skin?s white, but I?m not one
of the white people who?s destroying the world.??

As a zombie leftist during the 1960s and 1970s, I know what that feeling of desperation is like ? what it's like to be a self-hating white. We must get to the point where college-educated whites proudly and confidently say they are white and that they do not want to become a minority in America.

This reminds me of the recent docudrama Milk, which depicts the life of gay activist Harvey Milk. Milk is sure be nominated for an Oscar as Best Picture because it lovingly illustrates a triumph of the cultural left. But is has an important message that should resonate with the millions of whites who have been deprived of their
confidence and their culture: Be explicit. Just as Harvey Milk advocated being openly gay even in the face of dire consequences, whites need to tell their family and their friends that they have an identity as a white person and believe that whites have legitimate interests as white people. They must accept the consequences
when they are harassed, fired from their jobs, or put in prison for such beliefs. They must run for political office as openly pro-white.

Milk shows that homosexuals were fired from their jobs and arrested for congregating in public. Now it's the Southern Poverty Law Center and the rest of the leftist intellectual and political establishment that harasses and attempts to get people fired. But it's the same situation with the roles reversed. No revolution was ever
accomplished without some martyrs. The revolution that restores the legitimacy of white identity and the legitimacy of white interests will be no exception.

But it is a revolution that is absolutely necessary. The white majority is foolish indeed to entrust its future to a utopian hope that racial and ethnic identifications will disappear and that they won?t continue to influence public policy in ways that compromise the interests of whites.

It does not take an overactive imagination to see that coalitions of minority groups could compromise the interests of formerly dominant whites. We already see numerous examples in which coalitions of minority groups attempt to influence public policy, including immigration policy, against the interests of the whites. Placing
ourselves in a position of vulnerability would be extremely risky, given the deep sense of historical grievance fostered by many ethnic activists and organized ethnic lobbies.

This is especially the case with Jews. Jewish organisations have been unanimous in condemning Western societies, Western traditions, and Christianity, for past crimes against Jews. Similar sentiments are typical of a great many African Americans and Latinos, and especially among the ethnic activists from these groups. The
?God damn America? sermon by President Obama's pastor comes to mind as a recent notorious example.

The precedent of the early decades of the Soviet Union should give pause to anyone who believes that surrendering ethnic hegemony does not carry risks. The Bolshevik revolution had a pronounced ethnic angle: To a very great extent, Jews and other non-Russians ruled over the Russian people, with disastrous
consequences for the Russians and other ethnic groups that were not able to become part of the power structure. Jews formed a hostile elite within this power structure ? as they will in the future white-minority America; Jews were ?Stalin?s willing executioners.?

Two passages from my review of Yuri Slezkine's The Jewish Century seem particularly appropriate here. The first passage reminds me of the many American Jews who adopt a veneer of support for leftist versions of social justice and racial tolerance while nevertheless managing to support racial Zionism and the mass murder,
torture, and incarceration of the Palestinian people in one of the largest prison systems the world has ever seen. Such people may be very different when they become a hostile elite in a white-minority America.

Many of the commentators on Jewish Bolsheviks noted the ?transformation? of Jews [after the Bolshevik Revolution]. In the words of [a] Jewish commentator, G. A. Landau, ?cruelty, sadism, and violence had seemed alien to a nation so far removed from physical activity.? And another Jewish commentator, Ia. A. Bromberg, noted
that:

the formerly oppressed lover of liberty had turned into a tyrant of  ?unheard-of-despotic arbitrariness??. The convinced and unconditional opponent of the death penalty not just for political crimes but for the most heinous offenses, who could not, as it were, watch a chicken being killed, has been transformed outwardly into a
leather-clad person with a revolver and, in fact, lost all human likeness. ...

After the Revolution, ... there was active suppression of any remnants of the older order and their descendants. ... The mass murder of peasants and nationalists was combined with the systematic exclusion of the previously existing non-Jewish middle class. The wife of a Leningrad University professor noted, ?in all the
institutions, only workers and Israelites are admitted; the life of the intelligentsia is very hard? (p. 243). Even at the end of the 1930s, prior to the Russification that accompanied World War II, ?the Russian Federation?was still doing penance for its imperial past while also serving as an example of an ethnicity-free society? (p. 276).
While all other nationalities, including Jews, were allowed and encouraged to keep their ethnic identities, the revolution remained an anti-majoritarian movement.

The difference from the Soviet Union may well be that in white-minority America it will not be workers and Israelites who are favored, but non-whites and Israelites. Whites may dream that they are entering the post-racial utopia imagined by their erstwhile intellectual superiors. But it is quite possible that they are entering into a
racial dystopia of unimaginable cruelty in which whites will be systematically excluded in favor of the new elites recruited from the soon-to-be majority. It's happened before.

Kevin MacDonald is a professor of psychology at California State University?Long Beach.

Permanent URL with hyperlinks:

http://www.theoccidentalobserver.net/articles/MacDonald-Hsu.html

-----------


Should Christians Support Israeli Terrorism in Gaza?

A timely discussion between Rev. Ted Pike and Dr. David Duke, one especially important for the Christians in our audience

http://www.davidduke.com/mp3/dukeradio090122DukeandPikeonGaza.mp3

In this vital discussion, Rev. Pike and Dr. Duke explore the Pro-Israel attitude of some Christian evangelical organizations, and why their position not only goes directly against Christian morality and decency,  but actually is directly opposite of that expressed by Christian Scriptures. Today, Many Christians are instructed that Jews
and today?s Israel has a special covenant? with God. In fact, the New Testament in the clearest of language states that the Jews ?continued not in my covenant, and I considered them not, saith the Lord.? Here?s the quote that Christians aren?t supposed to notice.:

8:10 Not according to the covenant that I made with their fathers, in the day when I took them by the hand out of the land of Egypt; because they continued not in my covenant, and I regarded them not, saith the Lord. (Hebrews 8:10)

They also don?t seem to notice that a 2000 year old Judaic war against Christianity that has been waged since time of Jesus Christ and still goes on today with the most powerful Jewish organizations attempting to destroy European and American traditions, that has even become a war on our Christmas traditions.

Dr. Duke and Ted Pike also speak about how over a hundred thousand Christian Palestinians have suffered with their families from anti-Christian Israel! Christian support of Israel has resulted in the very birthplace of Jesus Christ, go from 90 percent Palestinian Christians to 35 percent today because of Israeli terror and
occupation. They ask, ?How could any Christian in good conscience support the anti-Christian state of Israel, bombing the homes, killing and maiming, torturing and oppressing fellow Christian men, women and children??

This is a vital show for every Christian reader and listener of DavidDuke.com. Next time, you hear someone say, ?God tells us that we must support Israel? you will have the clear Christian answer that just the opposite is true!

For documentation on this be sure to read some of the well-footnoted, sample chapters of Jewish Supremacism and My Awakening.

Source :
http://www.davidduke.com/general/should-christians-support-israeli-terrorism-in-gaza_7282.html


-------------------------------------

You or someone using your email adress is currently subscribed to the Lawrence Auster
Newletter. If you wish to unsubscribe from our mailing list, please let us know by calling to 1 212 865 1284

Thanks,

Lawrence Auster,
238 W 101 St Apt. 3B
New York, NY  10025
Contact: lawrence.auster at att.net
-------------------------------------



From ehuelsmann at common-lisp.net  Sat Jan 24 10:12:20 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 10:12:20 +0000
Subject: [armedbear-cvs] r11578 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQfUy-0006uG-SS@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 10:12:17 2009
New Revision: 11578

Log:
Miscelanious:
 - Merge [within p2-plus] (fixnum-type-p type2) case with (fixnum-type-p type1)
 - Add some cases handled by p2-plus to p2-minus too.
 - Fix parenthetical error

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 24 10:12:17 2009
@@ -2288,9 +2288,9 @@
                   +lisp-bignum+)
             (emit-invokevirtual +lisp-bignum-class+ "floatValue" nil "F"))
            ((typep form 'single-float)
-            (emit 'ldc (declare-float form)))
+            (emit 'ldc (pool-float form)))
            ((typep form 'double-float)
-            (emit 'ldc2_w (declare-double form))
+            (emit 'ldc2_w (pool-double form))
             (emit 'd2f))
            (t (assert nil)))
      (emit-move-from-stack target representation)
@@ -2306,15 +2306,15 @@
            ((integerp form)
             (emit 'getfield *this-class* (declare-bignum form)
                   +lisp-bignum+)
-            (emit-invokevirtual +lisp-bignum-class+ "doubleValue" nil "D")
+            (emit-invokevirtual +lisp-bignum-class+ "doubleValue" nil "D"))
            ((typep form 'single-float)
-            (emit 'ldc (declare-float form))
+            (emit 'ldc (pool-float form))
             (emit 'f2d))
            ((typep form 'double-float)
-            (emit 'ldc2_w (declare-double form)))
+            (emit 'ldc2_w (pool-double form)))
            (t (assert nil)))
      (emit-move-from-stack target representation)
-     (return-from compile-constant))))
+     (return-from compile-constant)))
   (cond ((fixnump form)
          (let ((translation (case form
                               (0  "ZERO")
@@ -6786,16 +6786,12 @@
              ((eql arg1 1)
 	      (compile-forms-and-maybe-emit-clear-values arg2 'stack nil)
               (emit-invoke-method "incr" target representation))
-             ((fixnum-type-p type1)
-	      (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-							 arg2 'stack nil)
-              (emit 'swap)
-              (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
-              (fix-boxing representation result-type)
-              (emit-move-from-stack target representation))
-             ((fixnum-type-p type2)
-	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
-							 arg2 'stack :int)
+             ((or (fixnum-type-p type1) (fixnum-type-p type2))
+	      (compile-forms-and-maybe-emit-clear-values
+                    arg1 'stack (when (fixnum-type-p type1) :int)
+                    arg2 'stack (when (fixnum-type-p type2) :int))
+              (when (fixnum-type-p type1)
+                (emit 'swap))
               (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
@@ -6867,10 +6863,14 @@
               (emit 'lsub)
               (convert-long representation)
               (emit-move-from-stack target representation))
-             ((fixnum-type-p type2)
-	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
-							 arg2 'stack :int)
-              (emit-invokevirtual +lisp-object-class+ "subtract" '("I") +lisp-object+)
+             ((or (fixnum-type-p type1) (fixnum-type-p type2))
+	      (compile-forms-and-maybe-emit-clear-values
+                    arg1 'stack (when (fixnum-type-p type1) :int)
+                    arg2 'stack (when (fixnum-type-p type2) :int))
+              (when (fixnum-type-p type1)
+                (emit 'swap))
+              (emit-invokevirtual +lisp-object-class+ "subtract"
+                                  '("I") +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
              (t



From ehuelsmann at common-lisp.net  Sat Jan 24 10:24:35 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 10:24:35 +0000
Subject: [armedbear-cvs] r11579 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQfgp-0007h8-Dz@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 10:24:34 2009
New Revision: 11579

Log:
Add floatValue() and doubleValue() to LispObject and all number classes which didn't have it yet.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Bignum.java
   trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java
   trunk/abcl/src/org/armedbear/lisp/Fixnum.java
   trunk/abcl/src/org/armedbear/lisp/LispObject.java
   trunk/abcl/src/org/armedbear/lisp/Ratio.java
   trunk/abcl/src/org/armedbear/lisp/SingleFloat.java

Modified: trunk/abcl/src/org/armedbear/lisp/Bignum.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Bignum.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Bignum.java	Sat Jan 24 10:24:34 2009
@@ -262,6 +262,7 @@
     return value.longValue();
   }
 
+  @Override
   public float floatValue() throws ConditionThrowable
   {
     float f = value.floatValue();
@@ -271,6 +272,7 @@
     return f;
   }
 
+  @Override
   public double doubleValue() throws ConditionThrowable
   {
     double d = value.doubleValue();

Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java	Sat Jan 24 10:24:34 2009
@@ -241,6 +241,11 @@
     }
 
     @Override
+    public double doubleValue() {
+        return value;
+    }
+
+    @Override
     public Object javaInstance()
     {
         return Double.valueOf(value);

Modified: trunk/abcl/src/org/armedbear/lisp/Fixnum.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Fixnum.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Fixnum.java	Sat Jan 24 10:24:34 2009
@@ -311,6 +311,16 @@
       }
   }
 
+  @Override
+  public float floatValue() {
+    return (float)value;
+  }
+
+  @Override
+  public double doubleValue() {
+    return (double)value;
+  }
+
   public static int getInt(LispObject obj) throws ConditionThrowable
   {
     try

Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispObject.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispObject.java	Sat Jan 24 10:24:34 2009
@@ -775,6 +775,20 @@
     return 0;
   }
 
+  public float floatValue() throws ConditionThrowable
+  {
+    type_error(this, Symbol.SINGLE_FLOAT);
+    // Not reached
+    return 0;
+  }
+
+  public double doubleValue() throws ConditionThrowable
+  {
+    type_error(this, Symbol.DOUBLE_FLOAT);
+    // Not reached
+    return 0;
+  }
+
   public LispObject incr() throws ConditionThrowable
   {
     return type_error(this, Symbol.NUMBER);

Modified: trunk/abcl/src/org/armedbear/lisp/Ratio.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Ratio.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Ratio.java	Sat Jan 24 10:24:34 2009
@@ -182,11 +182,13 @@
         return false;
     }
 
+    @Override
     public float floatValue()
     {
         return (float) doubleValue();
     }
 
+    @Override
     public double doubleValue()
     {
         double result = numerator.doubleValue() / denominator.doubleValue();

Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java	Sat Jan 24 10:24:34 2009
@@ -241,6 +241,16 @@
     }
 
     @Override
+    public float floatValue() {
+        return value;
+    }
+
+    @Override
+    public double doubleValue() {
+        return value;
+    }
+
+    @Override
     public Object javaInstance()
     {
         return Float.valueOf(value);



From ehuelsmann at common-lisp.net  Sat Jan 24 11:04:18 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 11:04:18 +0000
Subject: [armedbear-cvs] r11580 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQgJG-0001J5-3f@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 11:04:17 2009
New Revision: 11580

Log:
Commit some of the changes required for FLOAT and DOUBLE support (clean up my wc a bit)

- Add debugging output before triggering an ASSERT or AVER.
- Add boxing/unboxing routines (for future use).
- Add a new type (also for future use).

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 24 11:04:17 2009
@@ -222,6 +222,8 @@
 (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
 (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
 (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;")
+(defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger")
+(defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;")
 (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
 (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
@@ -735,6 +737,31 @@
          (emit 'checkcast +lisp-character-class+)
          (emit 'getfield +lisp-character-class+ "value" "C"))))
 
+(defknown emit-unbox-long () t)
+(defun emit-unbox-long ()
+  (emit-invokestatic +lisp-bignum-class+ "longValue"
+                     (lisp-object-arg-types 1) "J"))
+
+(defknown emit-unbox-float () t)
+(defun emit-unbox-float ()
+  (declare (optimize speed))
+  (cond ((= *safety* 3)
+         (emit-invokestatic +lisp-single-float-class+ "getValue"
+                            (lisp-object-arg-types 1) "F"))
+        (t
+         (emit 'checkcast +lisp-single-float-class+)
+         (emit 'getfield +lisp-single-float-class+ "value" "F"))))
+
+(defknown emit-unbox-double () t)
+(defun emit-unbox-double ()
+  (declare (optimize speed))
+  (cond ((= *safety* 3)
+         (emit-invokestatic +lisp-double-float-class+ "getValue"
+                            (lisp-object-arg-types 1) "D"))
+        (t
+         (emit 'checkcast +lisp-double-float-class+)
+         (emit 'getfield +lisp-double-float-class+ "value" "D"))))
+
 (defknown emit-unbox-boolean () t)
 (defun emit-unbox-boolean ()
   (let ((LABEL1 (gensym))
@@ -771,6 +798,13 @@
          (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D"))
         (t (assert nil))))
 
+(defknown emit-box-int () t)
+(defun emit-box-int ()
+  (declare (optimize speed))
+  (new-fixnum)
+  (emit 'dup_x1)
+  (emit-fixnum-init nil))
+
 (defknown emit-box-long () t)
 (defun emit-box-long ()
   (declare (optimize speed))
@@ -834,6 +868,7 @@
              'astore))
           target))
         (t
+         (sys::%format t "emit-move-from-stack general case~%")
          (aver nil))))
 
 ;; Expects value on stack.
@@ -2241,6 +2276,7 @@
             (emit-move-from-stack target representation)
             (return-from compile-constant))
            (t
+            (sys::%format t "compile-constant int representation~%")
             (assert nil))))
     (:long
      (cond ((fixnump form)
@@ -2263,6 +2299,7 @@
             (emit-move-from-stack target representation)
             (return-from compile-constant))
            (t
+            (sys::%format t "compile-constant long representation~%")
             (assert nil))))
     (:char
      (cond ((characterp form)
@@ -2270,6 +2307,7 @@
             (emit-move-from-stack target representation)
             (return-from compile-constant))
            (t
+            (sys::%format t "compile-constant :char representation~%")
             (assert nil))))
     (:boolean
      (emit (if form 'iconst_1 'iconst_0))
@@ -2292,7 +2330,9 @@
            ((typep form 'double-float)
             (emit 'ldc2_w (pool-double form))
             (emit 'd2f))
-           (t (assert nil)))
+           (t
+            (sys::%format t "compile-constant :float representation~%")
+            (assert nil)))
      (emit-move-from-stack target representation)
      (return-from compile-constant))
     (:double
@@ -2312,7 +2352,9 @@
             (emit 'f2d))
            ((typep form 'double-float)
             (emit 'ldc2_w (pool-double form)))
-           (t (assert nil)))
+           (t
+            (sys::%format t "compile-constant :double representation~%")
+            (assert nil)))
      (emit-move-from-stack target representation)
      (return-from compile-constant)))
   (cond ((fixnump form)
@@ -2540,7 +2582,9 @@
       (let ((variable (unboxed-fixnum-variable arg)))
         (if variable
             (emit 'iload (variable-register variable))
-            (aver nil)))))
+            (progn
+              (sys::%format t "emit-push-int~%")
+              (aver nil))))))
 
 (declaim (ftype (function (t) t) emit-push-long))
 (defun emit-push-long (arg)
@@ -3940,6 +3984,7 @@
          (emit 'swap) ; array index value
          (emit 'aastore))
         (t
+         (sys::%format t "compile-binding~%")
          (aver nil))))
 
 (defknown compile-progn-body (t t &optional t) t)
@@ -6457,6 +6502,7 @@
        (emit 'pop)
        (emit 'iconst_1))
       (:char
+       (sys::%format t "p2-length: :char case~%")
        (aver nil))
       (t
        (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+)))
@@ -7454,6 +7500,7 @@
                    (:int
                     (emit 'iload (variable-register variable)))
                    (:char
+                    (sys::%format t "compile-var-ref :char case~%")
                     (aver nil))
                    (:long
                     (emit 'iload (variable-register variable))
@@ -7486,6 +7533,7 @@
                     (emit 'lload (variable-register variable))
                     (emit 'l2i))
                    (:char
+                    (sys::%format t "compile-var-ref :char case 2~%")
                     (aver nil))
                    (:long
                     (emit 'lload (variable-register variable)))
@@ -7523,6 +7571,7 @@
                  (fix-boxing representation (variable-derived-type variable))
                  (emit-move-from-stack target representation))
                 (t
+                 (sys::%format t "compile-var-ref general case~%")
                  (aver nil)))))))
 
 (defun p2-set (form target representation)



From vvoutilainen at common-lisp.net  Sat Jan 24 13:26:38 2009
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 24 Jan 2009 13:26:38 +0000
Subject: [armedbear-cvs] r11581 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQiX0-0000Gx-Kp@common-lisp.net>

Author: vvoutilainen
Date: Sat Jan 24 13:26:18 2009
New Revision: 11581

Log:
Make directory listing tolerate invalid paths and permission
errors. Note: clisp raises errors on permission denied, sbcl
doesn't and returns NIL. This patch makes abcl mirror sbcl
behaviour, so it returns NIL instead of raising errors.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Pathname.java

Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java	Sat Jan 24 13:26:18 2009
@@ -1031,8 +1031,8 @@
             if (s != null) {
                 File f = new File(s);
                 if (f.isDirectory()) {
-                    File[] files = f.listFiles();
                     try {
+			File[] files = f.listFiles();
                         for (int i = files.length; i-- > 0;) {
                             File file = files[i];
                             Pathname p;
@@ -1047,6 +1047,10 @@
                         return error(new FileError("Unable to list directory " + pathname.writeToString() + ".",
                                                    pathname));
                     }
+                    catch (SecurityException e) {
+                    }
+                    catch (NullPointerException e) {
+                    }
                 }
             }
             return result;



From ehuelsmann at common-lisp.net  Sat Jan 24 14:02:20 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 14:02:20 +0000
Subject: [armedbear-cvs] r11582 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQj5Y-0002PQ-8S@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 14:02:18 2009
New Revision: 11582

Log:
Use additional opcodes: don't store the "obvious" constants in the constant pool.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/opcodes.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 24 14:02:18 2009
@@ -389,7 +389,26 @@
 
 (defknown emit-push-constant-long (integer) t)
 (defun emit-push-constant-long (n)
-  (emit 'ldc2_w (pool-long n)))
+  (case n
+    (0 (emit 'lconst_0))
+    (1 (emit 'lconst_1))
+    (t
+     (emit 'ldc2_w (pool-long n)))))
+
+(defknown emit-push-constant-float (single-float) t)
+(defun emit-push-constant-float (n)
+  (case n
+    (0.0s0 (emit 'fconst_0))
+    (1.0s0 (emit 'fconst_1))
+    (2.0s0 (emit 'fconst_2))
+    (t (emit 'ldc (pool-float n)))))
+
+(defknown emit-push-constant-double (double-float) t)
+(defun emit-push-constant-double (n)
+  (case n
+    (0.0d0 (emit 'dconst_0))
+    (1.0d0 (emit 'dconst_1))
+    (t (emit 'ldc2_w (pool-double n)))))
 
 (declaim (ftype (function (t t) cons) make-descriptor-info))
 (defun make-descriptor-info (arg-types return-type)
@@ -987,6 +1006,11 @@
                  8 ; iconst_5
                  9 ; lconst_0
                  10 ; lconst_1
+                 11 ; fconst_0
+                 12 ; fconst_1
+                 13 ; fconst_2
+                 14 ; dconst_0
+                 15 ; dconst_1
                  42 ; aload_0
                  43 ; aload_1
                  44 ; aload_2
@@ -2326,9 +2350,9 @@
                   +lisp-bignum+)
             (emit-invokevirtual +lisp-bignum-class+ "floatValue" nil "F"))
            ((typep form 'single-float)
-            (emit 'ldc (pool-float form)))
+            (emit-push-constant-float form))
            ((typep form 'double-float)
-            (emit 'ldc2_w (pool-double form))
+            (emit-push-constant-double form)
             (emit 'd2f))
            (t
             (sys::%format t "compile-constant :float representation~%")
@@ -2348,10 +2372,10 @@
                   +lisp-bignum+)
             (emit-invokevirtual +lisp-bignum-class+ "doubleValue" nil "D"))
            ((typep form 'single-float)
-            (emit 'ldc (pool-float form))
+            (emit-push-constant-float form)
             (emit 'f2d))
            ((typep form 'double-float)
-            (emit 'ldc2_w (pool-double form)))
+            (emit-push-constant-double form))
            (t
             (sys::%format t "compile-constant :double representation~%")
             (assert nil)))

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Sat Jan 24 14:02:18 2009
@@ -63,11 +63,11 @@
 (define-opcode iconst_5 8 1 1)
 (define-opcode lconst_0 9 1 2)
 (define-opcode lconst_1 10 1 2)
-(define-opcode fconst_0 11 1 nil)
-(define-opcode fconst_1 12 1 nil)
-(define-opcode fconst_2 13 1 nil)
-(define-opcode dconst_0 14 1 nil)
-(define-opcode dconst_1 15 1 nil)
+(define-opcode fconst_0 11 1 1)
+(define-opcode fconst_1 12 1 1)
+(define-opcode fconst_2 13 1 1)
+(define-opcode dconst_0 14 1 2)
+(define-opcode dconst_1 15 1 2)
 (define-opcode bipush 16 2 1)
 (define-opcode sipush 17 3 1)
 (define-opcode ldc 18 2 1)



From ehuelsmann at common-lisp.net  Sat Jan 24 18:08:11 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 18:08:11 +0000
Subject: [armedbear-cvs] r11583 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQmvT-0005fk-Qz@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 18:08:08 2009
New Revision: 11583

Log:
Revert change to p2-minus: we can't do this without adding a new LispObject primitive operation,
which I tried, but takes too long for now.

Note: the operation required would be negateAndAdd(int/long), which is easy except
      for that you need to add it to all number primitives...

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 24 18:08:08 2009
@@ -6862,7 +6862,8 @@
                     arg2 'stack (when (fixnum-type-p type2) :int))
               (when (fixnum-type-p type1)
                 (emit 'swap))
-              (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
+              (emit-invokevirtual +lisp-object-class+ "add"
+                                  '("I") +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
              (t
@@ -6933,13 +6934,12 @@
               (emit 'lsub)
               (convert-long representation)
               (emit-move-from-stack target representation))
-             ((or (fixnum-type-p type1) (fixnum-type-p type2))
+             ((fixnum-type-p type2)
 	      (compile-forms-and-maybe-emit-clear-values
-                    arg1 'stack (when (fixnum-type-p type1) :int)
-                    arg2 'stack (when (fixnum-type-p type2) :int))
-              (when (fixnum-type-p type1)
-                (emit 'swap))
-              (emit-invokevirtual +lisp-object-class+ "subtract"
+                    arg1 'stack nil
+                    arg2 'stack :int)
+              (emit-invokevirtual +lisp-object-class+
+                                  "subtract"
                                   '("I") +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))



From ehuelsmann at common-lisp.net  Sat Jan 24 18:33:43 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 18:33:43 +0000
Subject: [armedbear-cvs] r11584 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQnKA-0006aZ-J5@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 18:33:41 2009
New Revision: 11584

Log:
Handle both 'long' as well as 'double' argument and return types as types of size 2
regardless of whether we have those types now (we will later on...)

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 24 18:33:41 2009
@@ -420,10 +420,13 @@
                         (princ #\) s)
                         (princ (or return-type "V") s))))
         (stack-effect (let ((result (cond ((null return-type) 0)
-                                          ((equal return-type "J") 2)
+                                          ((or (equal return-type "J")
+                                               (equal return-type "D")) 2)
                                           (t 1))))
                         (dolist (type arg-types result)
-                          (decf result (if (equal type "J") 2 1))))))
+                          (decf result (if (or (equal type "J")
+                                               (equal type "D"))
+                                           2 1))))))
     (cons descriptor stack-effect)))
 
 (defparameter *descriptors* (make-hash-table :test #'equal))



From ehuelsmann at common-lisp.net  Sat Jan 24 18:59:58 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 18:59:58 +0000
Subject: [armedbear-cvs] r11585 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQnja-0007UE-SL@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 18:59:57 2009
New Revision: 11585

Log:
Update type mapping table in agreement to our earlier finding that in our lisp
simple-strings are also base-strings.

Modified:
   trunk/abcl/src/org/armedbear/lisp/subtypep.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/subtypep.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	Sat Jan 24 18:59:57 2009
@@ -93,7 +93,7 @@
                  (SIMPLE-BIT-VECTOR BIT-VECTOR SIMPLE-ARRAY)
                  (SIMPLE-CONDITION CONDITION)
                  (SIMPLE-ERROR SIMPLE-CONDITION ERROR)
-                 (SIMPLE-STRING STRING SIMPLE-ARRAY)
+                 (SIMPLE-STRING SIMPLE-BASE-STRING BASE-STRING STRING SIMPLE-ARRAY)
                  (SIMPLE-TYPE-ERROR SIMPLE-CONDITION TYPE-ERROR)
                  (SIMPLE-VECTOR VECTOR SIMPLE-ARRAY)
                  (SIMPLE-WARNING SIMPLE-CONDITION WARNING)



From ehuelsmann at common-lisp.net  Sat Jan 24 20:36:53 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 20:36:53 +0000
Subject: [armedbear-cvs] r11586 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQpFN-0003yJ-0A@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 20:36:52 2009
New Revision: 11586

Log:
Eliminate the pesky beeps in TYPE-OF.1; however unfortunately, this breaks TYPE-OF.4 for the case of "". Now go and search!

Modified:
   trunk/abcl/src/org/armedbear/lisp/subtypep.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/subtypep.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	Sat Jan 24 20:36:52 2009
@@ -93,7 +93,7 @@
                  (SIMPLE-BIT-VECTOR BIT-VECTOR SIMPLE-ARRAY)
                  (SIMPLE-CONDITION CONDITION)
                  (SIMPLE-ERROR SIMPLE-CONDITION ERROR)
-                 (SIMPLE-STRING SIMPLE-BASE-STRING BASE-STRING STRING SIMPLE-ARRAY)
+                 (SIMPLE-STRING BASE-STRING STRING SIMPLE-ARRAY)
                  (SIMPLE-TYPE-ERROR SIMPLE-CONDITION TYPE-ERROR)
                  (SIMPLE-VECTOR VECTOR SIMPLE-ARRAY)
                  (SIMPLE-WARNING SIMPLE-CONDITION WARNING)
@@ -483,6 +483,10 @@
             (eq type2 t)
             (and (classp type2) (eq (%class-name type2) t)))
     (return-from %subtypep (values t t)))
+  (when (classp type1)
+    (setf type1 (%class-name type1)))
+  (when (classp type2)
+    (setf type2 (%class-name type2)))
   (let ((ct1 (ctype type1))
         (ct2 (ctype type2)))
     (multiple-value-bind (subtype-p valid-p)



From ehuelsmann at common-lisp.net  Sat Jan 24 20:38:30 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Jan 2009 20:38:30 +0000
Subject: [armedbear-cvs] r11587 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LQpGw-00040p-8d@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 24 20:38:24 2009
New Revision: 11587

Log:
Ofcourse, you need all components for a commit to actually work... (Belongs to last commit.)

Modified:
   trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
   trunk/abcl/src/org/armedbear/lisp/SimpleString.java

Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java	Sat Jan 24 20:38:24 2009
@@ -236,9 +236,9 @@
     SIMPLE_BIT_VECTOR.setDirectSuperclasses(list2(BIT_VECTOR, SIMPLE_ARRAY));
     SIMPLE_BIT_VECTOR.setCPL(SIMPLE_BIT_VECTOR, BIT_VECTOR, VECTOR,
                              SIMPLE_ARRAY, ARRAY, SEQUENCE, CLASS_T);
-    SIMPLE_STRING.setDirectSuperclasses(list2(STRING, SIMPLE_ARRAY));
-    SIMPLE_STRING.setCPL(SIMPLE_STRING, STRING, VECTOR, SIMPLE_ARRAY, ARRAY,
-                         SEQUENCE, CLASS_T);
+    SIMPLE_STRING.setDirectSuperclasses(list3(BASE_STRING, STRING, SIMPLE_ARRAY));
+    SIMPLE_STRING.setCPL(SIMPLE_STRING, BASE_STRING, STRING, VECTOR,
+                         SIMPLE_ARRAY, ARRAY, SEQUENCE, CLASS_T);
     SIMPLE_VECTOR.setDirectSuperclasses(list2(VECTOR, SIMPLE_ARRAY));
     SIMPLE_VECTOR.setCPL(SIMPLE_VECTOR, VECTOR, SIMPLE_ARRAY, ARRAY, SEQUENCE,
                          CLASS_T);

Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SimpleString.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/SimpleString.java	Sat Jan 24 20:38:24 2009
@@ -97,13 +97,13 @@
     @Override
     public LispObject typeOf()
     {
-        return list2(Symbol.SIMPLE_STRING, new Fixnum(capacity));
+        return list2(Symbol.SIMPLE_BASE_STRING, new Fixnum(capacity));
     }
 
     @Override
     public LispObject classOf()
     {
-        return BuiltInClass.SIMPLE_STRING;
+        return BuiltInClass.SIMPLE_BASE_STRING;
     }
 
     @Override



From ehuelsmann at common-lisp.net  Sun Jan 25 10:13:52 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Jan 2009 10:13:52 +0000
Subject: [armedbear-cvs] r11588 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LR200-0004Rx-8C@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 25 10:13:49 2009
New Revision: 11588

Log:
Optimize MIN/MAX inline calculations: with the right stack use, we can avoid storing
and reloading of values with shorter execution paths and branches as a result.
Also enable the instructions pop2, dup2_x1 and dup2_x2.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/opcodes.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Jan 25 10:13:49 2009
@@ -1025,10 +1025,13 @@
                  78 ; astore_3
                  83 ; aastore
                  87 ; pop
+                 88 ; pop2
                  89 ; dup
                  90 ; dup_x1
                  91 ; dup_x2
                  92 ; dup2
+                 93 ; dup2_x1
+                 94 ; dup2_x2
                  95 ; swap
                  96 ; iadd
                  97 ; ladd
@@ -6724,70 +6727,47 @@
            (let ((type1 (derive-compiler-type arg1))
                  (type2 (derive-compiler-type arg2)))
              (cond ((and (fixnum-type-p type1) (fixnum-type-p type2))
-                    (let* ((*register* *register*)
-                           (reg1 (allocate-register))
-                           (reg2 (allocate-register)))
-		      (new-fixnum (null representation))
-                      (compile-form arg1 'stack :int)
-                      (emit 'dup)
-                      (emit 'istore reg1)
-                      (compile-form arg2 'stack :int)
-                      (emit 'dup)
-                      (emit 'istore reg2)
-                      (let ((LABEL1 (gensym))
-                            (LABEL2 (gensym)))
-                        (emit (if (eq op 'min) 'if_icmpge 'if_icmple) LABEL1)
-                        (emit 'iload reg1)
-                        (emit 'goto LABEL2)
-                        (label LABEL1)
-                        (emit 'iload reg2)
-                        (label LABEL2)))
+                    (new-fixnum (null representation))
+                    (compile-form arg1 'stack :int)
+                    (emit 'dup)
+                    (compile-form arg2 'stack :int)
+                    (emit 'dup_x1)
+                    (let ((LABEL1 (gensym)))
+                      (emit (if (eq op 'max) 'if_icmpge 'if_icmple) LABEL1)
+                      (emit 'swap)  ;; The lower stack value is greater-or-equal
+                      (label LABEL1)
+                      (emit 'pop))  ;; Throw away the lower stack value
 		    (emit-fixnum-init representation)
                     (emit-move-from-stack target representation))
                    ((and (java-long-type-p type1) (java-long-type-p type2))
-                    (let* ((*register* *register*)
-                           (reg1 (allocate-register-pair))
-                           (reg2 (allocate-register-pair)))
-                      (compile-form arg1 'stack :long)
-                      (emit 'dup2)
-                      (emit 'lstore reg1)
-                      (compile-form arg2 'stack :long)
-                      (emit 'dup2)
-                      (emit 'lstore reg2)
-                      (emit 'lcmp)
-                      (let ((LABEL1 (gensym))
-                            (LABEL2 (gensym)))
-                        (emit (if (eq op 'min) 'ifge 'ifle) LABEL1)
-                        (emit 'lload reg1)
-                        (emit 'goto LABEL2)
-                        (label LABEL1)
-                        (emit 'lload reg2)
-                        (label LABEL2)))
+                    (compile-form arg1 'stack :long)
+                    (emit 'dup2)
+                    (compile-form arg2 'stack :long)
+                    (emit 'dup2_x2)
+                    (emit 'lcmp)
+                    (let ((LABEL1 (gensym)))
+                      (emit (if (eq op 'max) 'ifge 'ifle) LABEL1)
+                      (emit 'dup2_x2) ;; pour-mans swap2
+                      (emit 'pop2)
+                      (label LABEL1)
+                      (emit 'pop2))
                     (convert-long representation)
                     (emit-move-from-stack target representation))
                    (t
-                    (let* ((*register* *register*)
-                           (reg1 (allocate-register))
-                           (reg2 (allocate-register)))
-                      (compile-form arg1 'stack nil)
-                      (emit 'dup)
-                      (astore reg1)
-                      (compile-form arg2 'stack nil)
-                      (emit 'dup)
-                      (astore reg2)
-                      (emit-invokevirtual +lisp-object-class+
-                                          (if (eq op 'min)
-                                              "isLessThanOrEqualTo"
-                                              "isGreaterThanOrEqualTo")
-                                          (lisp-object-arg-types 1) "Z")
-                      (let ((LABEL1 (gensym))
-                            (LABEL2 (gensym)))
+                    (compile-form arg1 'stack nil)
+                    (emit 'dup)
+                    (compile-form arg2 'stack nil)
+                    (emit 'dup_x1)
+                    (emit-invokevirtual +lisp-object-class+
+                                        (if (eq op 'max)
+                                            "isLessThanOrEqualTo"
+                                            "isGreaterThanOrEqualTo")
+                                        (lisp-object-arg-types 1) "Z")
+                      (let ((LABEL1 (gensym)))
                         (emit 'ifeq LABEL1)
-                        (aload reg1)
-                        (emit 'goto LABEL2)
+                        (emit 'swap)
                         (label LABEL1)
-                        (aload reg2)
-                        (label LABEL2)))
+                        (emit 'pop))
                     (fix-boxing representation nil)
                     (emit-move-from-stack target representation))))))
          (t

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Sun Jan 25 10:13:49 2009
@@ -140,13 +140,13 @@
 (define-opcode castore 85 1 nil)
 (define-opcode sastore 86 1 nil)
 (define-opcode pop 87 1 -1)
-(define-opcode pop2 88 1 nil)
+(define-opcode pop2 88 1 -2)
 (define-opcode dup 89 1 1)
 (define-opcode dup_x1 90 1 1)
 (define-opcode dup_x2 91 1 1)
 (define-opcode dup2 92 1 2)
-(define-opcode dup2_x1 93 1 nil)
-(define-opcode dup2_x2 94 1 nil)
+(define-opcode dup2_x1 93 1 2)
+(define-opcode dup2_x2 94 1 2)
 (define-opcode swap 95 1 0)
 (define-opcode iadd 96 1 -1)
 (define-opcode ladd 97 1 -2)



From ehuelsmann at common-lisp.net  Sun Jan 25 23:33:04 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Jan 2009 23:33:04 +0000
Subject: [armedbear-cvs] r11589 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LRETQ-0006zV-IA@common-lisp.net>

Author: ehuelsmann
Date: Sun Jan 25 23:33:01 2009
New Revision: 11589

Log:
Add stack information for opcodes we'll start using soon.

Modified:
   trunk/abcl/src/org/armedbear/lisp/opcodes.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Sun Jan 25 23:33:01 2009
@@ -150,16 +150,16 @@
 (define-opcode swap 95 1 0)
 (define-opcode iadd 96 1 -1)
 (define-opcode ladd 97 1 -2)
-(define-opcode fadd 98 1 nil)
-(define-opcode dadd 99 1 nil)
+(define-opcode fadd 98 1 -1)
+(define-opcode dadd 99 1 -2)
 (define-opcode isub 100 1 -1)
 (define-opcode lsub 101 1 -2)
 (define-opcode fsub 102 1 nil)
 (define-opcode dsub 103 1 nil)
 (define-opcode imul 104 1 -1)
 (define-opcode lmul 105 1 -2)
-(define-opcode fmul 106 1 nil)
-(define-opcode dmul 107 1 nil)
+(define-opcode fmul 106 1 -1)
+(define-opcode dmul 107 1 -2)
 (define-opcode idiv 108 1 nil)
 (define-opcode ldiv 109 1 nil)
 (define-opcode fdiv 110 1 nil)
@@ -186,14 +186,14 @@
 (define-opcode lxor 131 1 -2)
 (define-opcode iinc 132 3 0)
 (define-opcode i2l 133 1 1)
-(define-opcode i2f 134 1 nil)
-(define-opcode i2d 135 1 nil)
+(define-opcode i2f 134 1 0)
+(define-opcode i2d 135 1 1)
 (define-opcode l2i 136 1 -1)
 (define-opcode l2f 137 1 nil)
-(define-opcode l2d 138 1 nil)
+(define-opcode l2d 138 1 0)
 (define-opcode f2i 139 1 nil)
 (define-opcode f2l 140 1 nil)
-(define-opcode f2d 141 1 nil)
+(define-opcode f2d 141 1 1)
 (define-opcode d2i 142 1 nil)
 (define-opcode d2l 143 1 nil)
 (define-opcode d2f 144 1 nil)



From astalla at common-lisp.net  Sun Jan 25 23:34:25 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Sun, 25 Jan 2009 23:34:25 +0000
Subject: [armedbear-cvs] r11590 - in trunk/abcl: . src/META-INF
	src/org/armedbear/lisp src/org/armedbear/lisp/scripting
Message-ID: <E1LREUj-00072A-O1@common-lisp.net>

Author: astalla
Date: Sun Jan 25 23:34:24 2009
New Revision: 11590

Log:
Merged the scripting branch, providing JSR-223 support and other new 
features. JSR-233 is only built if the necessary javax.script.* classes 
are found in the CLASSPATH.


Added:
   trunk/abcl/src/META-INF/
      - copied from r11575, /branches/scripting/j/src/META-INF/
   trunk/abcl/src/org/armedbear/lisp/JavaClass.java
      - copied unchanged from r11575, /branches/scripting/j/src/org/armedbear/lisp/JavaClass.java
   trunk/abcl/src/org/armedbear/lisp/scripting/
      - copied from r11575, /branches/scripting/j/src/org/armedbear/lisp/scripting/
Modified:
   trunk/abcl/build.xml
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/JProxy.java
   trunk/abcl/src/org/armedbear/lisp/Java.java
   trunk/abcl/src/org/armedbear/lisp/JavaObject.java
   trunk/abcl/src/org/armedbear/lisp/LispObject.java
   trunk/abcl/src/org/armedbear/lisp/StandardClass.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/src/org/armedbear/lisp/java.lisp
   trunk/abcl/src/org/armedbear/lisp/print-object.lisp

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Sun Jan 25 23:34:24 2009
@@ -19,7 +19,7 @@
 	      value="${dist.dir}/abcl.jar"/>
     <property name="abcl.ext.dir"
 	      value="${basedir}/ext"/>
-
+	
     <target name="help">
       <echo>Main Ant targets:
  abcl.compile  
@@ -37,15 +37,23 @@
       <echo>Corresponding targets for J have been removed.</echo>
     </target>
 
+    <!-- Checks if JSR-223 support is available - thanks to Mark Everson -->
+    <available property="abcl.jsr-223.p"
+	       classname="javax.script.ScriptEngine"/>
+
     <patternset id="abcl.source.java">
       <include name="org/armedbear/lisp/*.java"/>
       <include name="org/armedbear/lisp/util/*.java"/>
+      <include name="org/armedbear/lisp/scripting/*.java" if="abcl.jsr-223.p"/>
+      <include name="org/armedbear/lisp/scripting/util/*.java" if="abcl.jsr-223.p"/>
+      <include name="org/armedbear/Main.java"/>
     </patternset>
 
     <patternset id="abcl.source.lisp">
       <include name="org/armedbear/lisp/*.lisp"/>
       <include name="org/armedbear/lisp/tests/*.lisp"/>
       <exclude name="org/armedbear/lisp/j.lisp"/>
+      <include name="org/armedbear/lisp/scripting/lisp/*.lisp" if="abcl.jsr-223.p"/>
     </patternset>
 
     <patternset id="abcl.scripting.source.java">
@@ -60,6 +68,7 @@
     <!-- Lisp files required at runtime -->
     <patternset id="abcl.source.lisp.dist">
       <include name="org/armedbear/lisp/boot.lisp"/>
+	  <include name="org/armedbear/lisp/scripting/lisp/*.lisp" if="abcl.jsr-223.p"/>
     </patternset>
 
     <patternset id="abcl.objects">
@@ -67,6 +76,8 @@
       <include name="org/armedbear/lisp/util/*.class"/>
       <include name="org/armedbear/lisp/*.cls"/> 
       <include name="org/armedbear/lisp/*.abcl"/>
+      <include name="org/armedbear/lisp/scripting/*.class" if="abcl.jsr-223.p"/>
+      <include name="org/armedbear/lisp/scripting/util/*.class" if="abcl.jsr-223.p"/>
       <patternset refid="abcl.source.lisp.dist"/>
     </patternset>
     
@@ -127,8 +138,14 @@
       <echo>WARNING: Use of Java version ${java.version} not recommended.</echo>
     </target>
 	
+    <target name="abcl.jsr-223.notice"
+	    depends="abcl.init"
+	    unless="abcl.jsr-223.p">
+      <echo>Notice: JSR-223 support won't be built since it is not supported, neither natively by your JVM nor by libraries in the CLASSPATH.</echo>
+    </target>
+
     <target name="abcl.compile.java" 
-	    depends="abcl.init,abcl.java.warning">
+	    depends="abcl.init,abcl.java.warning,abcl.jsr-223.notice">
       <mkdir dir="${build.dir}"/>
       <mkdir dir="${build.classes.dir}"/>
       <javac destdir="${build.classes.dir}"
@@ -236,6 +253,8 @@
 		       value="${version.src}"/>
 	  </section>
 	</manifest>
+      	<metainf dir="${src.dir}/META-INF">
+      	</metainf>
       </jar>
     </target>
     

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Sun Jan 25 23:34:24 2009
@@ -513,6 +513,9 @@
         autoload(PACKAGE_EXT, "thread-lock", "ThreadLock", true);
         autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true);
         autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
+        autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass");
+        autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
+        autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");
         autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");
         autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass");
         autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");

Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JProxy.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/JProxy.java	Sun Jan 25 23:34:24 2009
@@ -134,4 +134,114 @@
       return null;
     }
   }
+  
+  	//NEW IMPLEMENTATION by Alessio Stalla 
+  
+  	/**
+  	 * A weak map associating each proxy instance with a "Lisp-this" object. 
+  	 */
+  	private static final Map<Object, LispObject> proxyMap = new WeakHashMap<Object, LispObject>();
+  
+  	public static class LispInvocationHandler implements InvocationHandler {
+  		
+  		private Function function;
+  		private static Method hashCodeMethod;
+  		private static Method equalsMethod;
+  		private static Method toStringMethod;
+  		
+  		static {
+  			try {
+				hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {});
+				equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class });
+				toStringMethod = Object.class.getMethod("toString", new Class[] {});
+			} catch (Exception e) {
+				throw new Error("Something got horribly wrong - can't get a method from Object.class", e);
+			}
+  		}
+
+  		public LispInvocationHandler(Function function) {
+  			this.function = function;
+  		}
+  		
+		public Object invoke(Object proxy, Method method, Object[] args) throws Throwable {
+	    	if(hashCodeMethod.equals(method)) {
+	    		return System.identityHashCode(proxy);
+	    	}
+	    	if(equalsMethod.equals(method)) {
+	    		return proxy == args[0];
+	    	}
+	    	if(toStringMethod.equals(method)) {
+	    		return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode());
+	    	}
+	    	
+	    	if(args == null) {
+	    		args = new Object[0];
+	    	}
+			LispObject[] lispArgs = new LispObject[args.length + 2];
+			synchronized(proxyMap) {
+				lispArgs[0] = toLispObject(proxyMap.get(proxy));
+			}
+			lispArgs[1] = new SimpleString(method.getName());
+			for(int i = 0; i < args.length; i++) {
+				lispArgs[i + 2] = toLispObject(args[i]);
+			}
+			Object retVal = (function.execute(lispArgs)).javaInstance();
+			/* DOES NOT WORK due to autoboxing!
+			if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) {
+				return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType())));
+			}*/
+			return retVal;
+		}
+	}
+  
+  	private static final Primitive _JMAKE_INVOCATION_HANDLER =
+	    new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false,
+	                  "function") {
+		
+	      	public LispObject execute(LispObject[] args) throws ConditionThrowable {
+	      		int length = args.length;
+	      		if (length != 1) {
+	      			return error(new WrongNumberOfArgumentsException(this));
+	      		}
+	      		if(!(args[0] instanceof Function)) {
+	      			return error(new TypeError(args[0], Symbol.FUNCTION));
+	      		}
+	      		return new JavaObject(new LispInvocationHandler((Function) args[0]));
+	      	}
+	    };
+
+    private static final Primitive _JMAKE_PROXY =
+	    new Primitive("%jmake-proxy", PACKAGE_JAVA, false,
+	                  "interface invocation-handler") {
+		
+	      	public LispObject execute(final LispObject[] args) throws ConditionThrowable {
+	      		int length = args.length;
+	      		if (length != 3) {
+	      			return error(new WrongNumberOfArgumentsException(this));
+	      		}
+	      		if(!(args[0] instanceof JavaObject) ||
+	      		   !(((JavaObject) args[0]).javaInstance() instanceof Class)) {
+	      			return error(new TypeError(args[0], new SimpleString(Class.class.getName())));
+	      		}
+	      		if(!(args[1] instanceof JavaObject) ||
+ 	      		   !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) {
+ 	      			return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName())));
+ 	      		}
+	      		Class<?> iface = (Class<?>) ((JavaObject) args[0]).javaInstance();
+	      		InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance();
+	      		Object proxy = Proxy.newProxyInstance(
+	      				iface.getClassLoader(),
+	      				new Class[] { iface },
+	      				invocationHandler);
+	      		synchronized(proxyMap) {
+	      			proxyMap.put(proxy, args[2]);
+	      		}
+	      		return new JavaObject(proxy);
+	      	}
+	    };    
+	    
+	private static LispObject toLispObject(Object obj) {
+		return (obj instanceof LispObject) ? (LispObject) obj : new JavaObject(obj);
+	}
+	    
 }

Modified: trunk/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Java.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Java.java	Sun Jan 25 23:34:24 2009
@@ -33,14 +33,18 @@
 
 package org.armedbear.lisp;
 
+import java.beans.BeanInfo;
+import java.beans.IntrospectionException;
+import java.beans.Introspector;
+import java.beans.PropertyDescriptor;
 import java.lang.reflect.Array;
 import java.lang.reflect.Constructor;
 import java.lang.reflect.Field;
 import java.lang.reflect.InvocationTargetException;
 import java.lang.reflect.Method;
 import java.lang.reflect.Modifier;
-import java.util.Map;
 import java.util.HashMap;
+import java.util.Map;
 
 public final class Java extends Lisp
 {
@@ -722,7 +726,72 @@
             return makeLispObject(arg.javaInstance());
         }
     };
-
+    
+    private static final Primitive JGET_PROPERTY_VALUE =
+	    new Primitive("%jget-property-value", PACKAGE_JAVA, true,
+	                  "java-object property-name") {
+    	
+    	public LispObject execute(LispObject javaObject, LispObject propertyName) throws ConditionThrowable {
+			try {
+				Object obj = javaObject.javaInstance();
+				PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
+				Object value = pd.getReadMethod().invoke(obj);
+				if(value instanceof LispObject) {
+				    return (LispObject) value;
+				} else if(value != null) {
+				    return new JavaObject(value);
+				} else {
+				    return NIL;
+				}
+			} catch (Exception e) {
+				ConditionThrowable t = new ConditionThrowable("Exception reading property");
+				t.initCause(e);
+				throw t;
+			}
+        }
+    };
+    
+    private static final Primitive JSET_PROPERTY_VALUE =
+	    new Primitive("%jset-property-value", PACKAGE_JAVA, true,
+	                  "java-object property-name value") {
+    	
+    	public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable {
+	    Object obj = null;
+	    try {
+		obj = javaObject.javaInstance();
+		PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
+		Object jValue;
+		if(value == NIL) {
+		    if(Boolean.TYPE.equals(pd.getPropertyType()) ||
+		       Boolean.class.equals(pd.getPropertyType())) {
+			jValue = false;
+		    } else {
+			jValue = null;
+		    }
+		} else {
+		    jValue = value.javaInstance();
+		}
+		pd.getWriteMethod().invoke(obj, jValue);
+		return value;
+	    } catch (Exception e) {
+		ConditionThrowable t = new ConditionThrowable("Exception writing property " + propertyName.writeToString() + " in object " + obj + " to " + value.writeToString());
+		t.initCause(e);
+		throw t;
+	    }
+        }
+    };
+    
+    private static PropertyDescriptor getPropertyDescriptor(Object obj, LispObject propertyName) throws ConditionThrowable, IntrospectionException {
+        String prop = ((AbstractString) propertyName).getStringValue();
+        BeanInfo beanInfo = Introspector.getBeanInfo(obj.getClass());
+        for(PropertyDescriptor pd : beanInfo.getPropertyDescriptors()) {
+        	if(pd.getName().equals(prop)) {
+        		return pd;
+        	}
+        }
+		throw new ConditionThrowable("Property " + prop + " not found in " + obj);
+    }
+    
     private static Class classForName(String className) throws ConditionThrowable
     {
         try {

Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JavaObject.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java	Sun Jan 25 23:34:24 2009
@@ -51,7 +51,11 @@
     @Override
     public LispObject classOf()
     {
-        return BuiltInClass.JAVA_OBJECT;
+    	if(obj == null) {
+    		return BuiltInClass.JAVA_OBJECT;
+    	} else {
+    		return JavaClass.findJavaClass(obj.getClass());
+    	}
     }
 
     @Override
@@ -61,6 +65,9 @@
             return T;
         if (type == BuiltInClass.JAVA_OBJECT)
             return T;
+        if(type instanceof JavaClass && obj != null) {
+        	return ((JavaClass) type).getJavaClass().isAssignableFrom(obj.getClass()) ? T : NIL;
+        }
         return super.typep(type);
     }
 

Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispObject.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispObject.java	Sun Jan 25 23:34:24 2009
@@ -101,8 +101,9 @@
 
   public Object javaInstance() throws ConditionThrowable
   {
-    return error(new LispError("The value " + writeToString() +
-                                " is not of primitive type."));
+	return this;
+    /*return error(new LispError("The value " + writeToString() +
+                                " is not of primitive type."));*/
   }
 
   public Object javaInstance(Class c) throws ConditionThrowable

Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sun Jan 25 23:34:24 2009
@@ -123,6 +123,9 @@
   public static final StandardClass BUILT_IN_CLASS =
     addStandardClass(Symbol.BUILT_IN_CLASS, list1(CLASS));
 
+  public static final StandardClass JAVA_CLASS =
+	    addStandardClass(Symbol.JAVA_CLASS, list1(CLASS));
+  
   public static final StandardClass FORWARD_REFERENCED_CLASS =
     addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list1(CLASS));
 
@@ -280,6 +283,8 @@
                                list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS")))));
     BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT,
                           BuiltInClass.CLASS_T);
+    JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT,
+            BuiltInClass.CLASS_T);
     CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
                       STANDARD_OBJECT, BuiltInClass.CLASS_T);
     CELL_ERROR.setDirectSlotDefinitions(

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Sun Jan 25 23:34:24 2009
@@ -2899,6 +2899,8 @@
     PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION-CAUSE");
   public static final Symbol JAVA_OBJECT =
     PACKAGE_JAVA.addExternalSymbol("JAVA-OBJECT");
+  public static final Symbol JAVA_CLASS =
+	    PACKAGE_JAVA.addExternalSymbol("JAVA-CLASS");
   public static final Symbol JCALL =
     PACKAGE_JAVA.addExternalSymbol("JCALL");
   public static final Symbol JCALL_RAW =

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Sun Jan 25 23:34:24 2009
@@ -199,6 +199,12 @@
 (autoload 'jregister-handler "java")
 (export 'jinterface-implementation "JAVA")
 (autoload 'jinterface-implementation "java")
+(export 'jmake-invocation-handler "JAVA")
+(autoload 'jmake-invocation-handler "java")
+(export 'jmake-proxy "JAVA")
+(autoload 'jmake-proxy "java")
+(export 'jproperty-value "JAVA")
+(autoload 'jproperty-value "java")
 (export 'jobject-class "JAVA")
 (autoload 'jobject-class "java")
 (export 'jclass-superclass "JAVA")

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Jan 25 23:34:24 2009
@@ -908,6 +908,13 @@
                       (eq (car object) 'quote))
              (setf object (cadr object)))
            (intern-eql-specializer object)))
+	((and (consp specializer)
+              (eq (car specializer) 'java:jclass))
+         (let ((class-name (cadr specializer)))
+           (when (and (consp class-name)
+                      (eq (car class-name) 'quote))
+             (setf class-name (cadr class-name)))
+           (java::%find-java-class class-name)))
         (t
          (error "Unknown specializer: ~S" specializer))))
 

Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp	Sun Jan 25 23:34:24 2009
@@ -75,6 +75,64 @@
         (push method-name method-names-and-defs)))
     (apply #'%jnew-proxy interface method-names-and-defs)))
 
+(defun jmake-invocation-handler (function)
+  (%jmake-invocation-handler function))
+
+(when (autoloadp 'jmake-proxy)
+  (fmakunbound 'jmake-proxy))
+
+(defgeneric jmake-proxy (interface implementation &optional lisp-this)
+  (:documentation "Returns a proxy Java object implementing the provided interface using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters."))
+
+(defmethod jmake-proxy (interface invocation-handler &optional lisp-this)
+  "Basic implementation that directly uses an invocation handler."
+  (%jmake-proxy (jclass interface) invocation-handler lisp-this))
+
+(defmethod jmake-proxy (interface (implementation function) &optional lisp-this)
+  "Implements a Java interface forwarding method calls to a Lisp function."
+  (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this))
+
+(defmethod jmake-proxy (interface (implementation package) &optional lisp-this)
+  "Implements a Java interface mapping Java method names to symbols in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME symbol. An error is signaled if no such symbol exists in the package, or if the symbol exists but does not name a function."
+  (flet ((java->lisp (name)
+	   (with-output-to-string (str)
+	     (let ((last-lower-p nil))
+	       (map nil (lambda (char)
+			  (let ((upper-p (char= (char-upcase char) char)))
+			    (when (and last-lower-p upper-p)
+			      (princ "-" str))
+			    (setf last-lower-p (not upper-p))
+			    (princ (char-upcase char) str)))
+		    name)))))
+    (%jmake-proxy (jclass interface)
+		  (jmake-invocation-handler 
+		   (lambda (obj method &rest args)
+		     (let ((sym (find-symbol
+				 (java->lisp method)
+				 implementation)))
+		       (unless sym
+			 (error "Symbol ~A, implementation of method ~A, not found in ~A"
+				  (java->lisp method)
+				  method
+				  implementation))
+			 (if (fboundp sym)
+			     (apply (symbol-function sym) obj method args)
+			     (error "Function ~A, implementation of method ~A, not found in ~A"
+				    sym method implementation)))))
+		  lisp-this)))
+
+(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this)
+  "Implements a Java interface using closures in an hash-table keyed by Java method name."
+  (%jmake-proxy (jclass interface)
+		(jmake-invocation-handler 
+		 (lambda (obj method &rest args)
+		   (let ((fn (gethash method implementation)))
+		     (if fn
+			 (apply fn obj args)
+			 (error "Implementation for method ~A not found in ~A"
+				method implementation)))))
+		lisp-this))
+
 (defun jobject-class (obj)
   "Returns the Java class that OBJ belongs to"
   (jcall (jmethod "java.lang.Object" "getClass") obj))
@@ -232,4 +290,10 @@
      (t
       (error "Unknown load-from for ~A" class-name)))))
 
+(defun jproperty-value (obj prop)
+  (%jget-property-value obj prop))
+
+(defun (setf jproperty-value) (value obj prop)
+  (%jset-property-value obj prop value))
+
 (provide "JAVA-EXTENSIONS")

Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print-object.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp	Sun Jan 25 23:34:24 2009
@@ -50,6 +50,9 @@
     (format stream "~S" (class-name (class-of object))))
   object)
 
+(defmethod print-object ((class java:java-class) stream)
+  (write-string (%write-to-string class) stream))
+
 (defmethod print-object ((class class) stream)
   (print-unreadable-object (class stream :identity t)
     (format stream "~S ~S"



From ehuelsmann at common-lisp.net  Mon Jan 26 19:29:55 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Jan 2009 19:29:55 +0000
Subject: [armedbear-cvs] r11591 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LRX9f-0006ha-MY@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 26 19:29:53 2009
New Revision: 11591

Log:
Make SINGLE-FLOAT and DOUBLE-FLOAT compiler types.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp	Mon Jan 26 19:29:53 2009
@@ -144,12 +144,26 @@
          typespec)
         ((constant-type-p typespec)
          typespec)
+        ((eq typespec 'SINGLE-FLOAT)
+         'SINGLE-FLOAT)
+        ((eq typespec 'DOUBLE-FLOAT)
+         'DOUBLE-FLOAT)
+        ((and (consp typespec)
+              (eq (%car typespec) 'SINGLE-FLOAT))
+         'SINGLE-FLOAT)
+        ((and (consp typespec)
+              (eq (%car typespec) 'DOUBLE-FLOAT))
+         'DOUBLE-FLOAT)
         (t
          (let ((type (normalize-type typespec)))
            (cond ((consp type)
                   (let ((car (%car type)))
                     (cond ((eq car 'INTEGER)
                            (make-integer-type type))
+                          ((eq car 'SINGLE-FLOAT)
+                           'SINGLE-FLOAT)
+                          ((eq car 'DOUBLE-FLOAT)
+                           'DOUBLE-FLOAT)
                           ((memq car '(STRING SIMPLE-STRING LIST))
                            car)
                           ((memq car '(VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY))



From ehuelsmann at common-lisp.net  Mon Jan 26 21:02:42 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Jan 2009 21:02:42 +0000
Subject: [armedbear-cvs] r11592 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LRYbS-00039J-Pl@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 26 21:02:42 2009
New Revision: 11592

Log:
Generic representation conversion (from one JVM type to another) and boxing (JVM type to LispObject) support.

Removes EMIT-BOX-* and CONVERT-* functions as they're now part of the generic framework.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Jan 26 21:02:42 2009
@@ -498,6 +498,60 @@
       (setf pretty-string (concatenate 'string pretty-string "[]")))
     pretty-string))
 
+;;                     source type /
+;;                         targets   :boolean :char    :int :long :float :double
+(defvar rep-conversion '((:boolean . #( NIL    :err    :err  :err  :err   :err))
+                         (:char    . #(  1     NIL     :err  :err  :err   :err))
+                         (:int     . #(  1     :err     NIL  i2l   i2f    i2d))
+                         (:long    . #(  1     :err     l2i  NIL   l2f    l2d))
+                         (:float   . #(  1     :err    :err  :err  NIL    f2d))
+                         (:double  . #(  1     :err    :err  :err  d2f    NIL)))
+  "Contains a table with operations to be performed to do
+internal representation conversion.")
+
+(defvar rep-classes
+  '((:boolean  #.+lisp-object-class+        #.+lisp-object+)
+    (:char     #.+lisp-character-class+     #.+lisp-character+)
+    (:int      #.+lisp-integer-class+       #.+lisp-integer+)
+    (:long     #.+lisp-integer-class+       #.+lisp-integer+)
+    (:float    #.+lisp-single-float-class+  #.+lisp-single-float+)
+    (:double   #.+lisp-double-float-class+  #.+lisp-double-float+))
+  "Lists the class on which to call the `getInstance' method on,
+when converting the internal representation to a LispObject.")
+
+(defvar rep-arg-chars
+  '((:boolean . "Z")
+    (:char    . "C")
+    (:int     . "I")
+    (:long    . "J")
+    (:float   . "F")
+    (:double  . "D"))
+  "Lists the argument type identifiers for each
+of the internal representations.")
+
+(defun convert-representation (in out)
+  "Converts the value on the stack in the `in' representation
+to a value on the stack in the `out' representation."
+  (when (null out)
+    ;; Convert back to a lisp object
+    (when in
+      (let ((class (cdr (assoc in rep-classes)))
+            (arg-spec (cdr (assoc in rep-arg-chars))))
+        (emit-invokestatic (first class) "getInstance" (list arg-spec)
+                           (second class))))
+    (return-from convert-representation))
+  (let* ((in-map (cdr (assoc in rep-conversion)))
+         (op-num (position out '(:boolean :char :int :long :float :double)))
+         (op (aref in-map op-num)))
+    (when op
+      ;; Convert from one internal representation into another
+      (assert (neq op :err))
+      (if (eql op 1)
+          (progn
+            (emit-move-from-stack nil in)
+            (emit 'iconst_1))
+          (emit op)))))
+
 (declaim (ftype (function t string) pretty-java-class))
 (defun pretty-java-class (class)
   (cond ((equal class +lisp-object-class+)
@@ -820,50 +874,6 @@
          (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D"))
         (t (assert nil))))
 
-(defknown emit-box-int () t)
-(defun emit-box-int ()
-  (declare (optimize speed))
-  (new-fixnum)
-  (emit 'dup_x1)
-  (emit-fixnum-init nil))
-
-(defknown emit-box-long () t)
-(defun emit-box-long ()
-  (declare (optimize speed))
-  (emit-invokestatic +lisp-class+ "number" '("J") +lisp-object+))
-
-(defknown emit-box-float () t)
-(defun emit-box-float ()
-  (emit 'new +lisp-single-float-class+)
-  (emit 'dup_x1)
-  (emit-invokespecial-init +lisp-single-float-class+ '("F")))
-
-(defknown emit-box-double () t)
-(defun emit-box-double ()
-  (emit 'new +lisp-double-float-class+)
-  (emit 'dup_x2)
-  (emit-invokespecial-init +lisp-double-float-class+ '("D")))
-
-(defknown convert-long (t) t)
-(defun convert-long (representation)
-  (case representation
-    (:int
-     (emit 'l2i))
-    (:long)
-    (t
-     (emit-box-long))))
-
-(defknown emit-box-boolean () t)
-(defun emit-box-boolean ()
-  (let ((LABEL1 (gensym))
-        (LABEL2 (gensym)))
-    (emit 'ifeq LABEL1)
-    (emit-push-t)
-    (emit 'goto LABEL2)
-    (label LABEL1)
-    (emit-push-nil)
-    (label LABEL2)))
-
 (defknown emit-move-from-stack (t &optional t) t)
 (defun emit-move-from-stack (target &optional representation)
   (declare (optimize speed))
@@ -5259,7 +5269,7 @@
                   (emit 'lshr))
                  ((zerop constant-shift)
                   (compile-form arg2 nil nil))) ; for effect
-           (convert-long representation)
+           (convert-representation :long representation)
            (emit-move-from-stack target representation))
           ((and (fixnum-type-p type1)
                 low2 high2 (<= -31 low2 high2 0)) ; Negative shift.
@@ -5277,7 +5287,7 @@
 		  (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							     arg2 'stack :int)
                   (emit 'lshl)
-                  (convert-long representation))
+                  (convert-representation :long representation))
                  ((and low2 high2 (<= -63 low2 high2 0) ; Negative shift.
                        (java-long-type-p type1)
                        (java-long-type-p result-type))
@@ -5285,7 +5295,7 @@
 							     arg2 'stack :int)
                   (emit 'ineg)
                   (emit 'lshr)
-                  (convert-long representation))
+                  (convert-representation :long representation))
                  (t
 ;;                   (format t "p2-ash call to LispObject.ash(int)~%")
 ;;                   (format t "p2-ash type1 = ~S type2 = ~S~%" type1 type2)
@@ -5360,7 +5370,7 @@
                    (emit 'l2i))
                   (:long)
                   (t
-                   (emit-box-long)))
+                   (convert-representation :long nil)))
                 (emit-move-from-stack target representation))
                ((or (and (java-long-type-p type1)
                          (compiler-subtypep type1 'unsigned-byte))
@@ -5375,7 +5385,7 @@
                    (emit 'l2i))
                   (:long)
                   (t
-                   (emit-box-long)))
+                   (convert-representation :long nil)))
                 (emit-move-from-stack target representation))
                ((fixnum-type-p type2)
                 ;;                     (format t "p2-logand LispObject.LOGAND(int) 1~%")
@@ -5451,7 +5461,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							   arg2 'stack :long)
                 (emit 'lor)
-                (convert-long representation)
+                (convert-representation :long representation)
                 (emit-move-from-stack target representation))
                ((fixnum-type-p type2)
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
@@ -5518,7 +5528,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							   arg2 'stack :long)
                 (emit 'lxor)
-                (convert-long representation))
+                (convert-representation :long representation))
                ((fixnum-type-p type2)
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							   arg2 'stack :int)
@@ -5603,7 +5613,7 @@
                         (t
                          (emit-push-constant-long (1- (expt 2 size))) ; mask
                          (emit 'land)
-                         (convert-long representation)))
+                         (convert-representation :long representation)))
                   (emit-move-from-stack target representation))
                  (t
 		  (compile-forms-and-maybe-emit-clear-values arg3 'stack nil)
@@ -6651,7 +6661,7 @@
   (emit 'i2l)
   (maybe-emit-clear-values arg1 arg2)
   (emit instruction)
-  (convert-long representation))
+  (convert-representation :long representation))
 
 (defun p2-times (form target representation)
   (case (length form)
@@ -6682,7 +6692,7 @@
                      (unless (eq representation :int)
                        (emit-invokespecial-init +lisp-fixnum-class+ '("I"))
                        (fix-boxing representation 'fixnum)))
-                    (t
+                      (t
 		     (two-long-ints-times/plus/minus 
 		      arg1 arg2 'lmul representation)))
 	      (emit-move-from-stack target representation))
@@ -6692,7 +6702,7 @@
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							 arg2 'stack :long)
               (emit 'lmul)
-              (convert-long representation)
+              (convert-representation :long representation)
               (emit-move-from-stack target representation))
              ((fixnump arg2)
 ;;               (format t "p2-times case 3~%")
@@ -6727,31 +6737,31 @@
            (let ((type1 (derive-compiler-type arg1))
                  (type2 (derive-compiler-type arg2)))
              (cond ((and (fixnum-type-p type1) (fixnum-type-p type2))
-                    (new-fixnum (null representation))
-                    (compile-form arg1 'stack :int)
-                    (emit 'dup)
-                    (compile-form arg2 'stack :int)
+		      (new-fixnum (null representation))
+                      (compile-form arg1 'stack :int)
+                      (emit 'dup)
+                      (compile-form arg2 'stack :int)
                     (emit 'dup_x1)
                     (let ((LABEL1 (gensym)))
                       (emit (if (eq op 'max) 'if_icmpge 'if_icmple) LABEL1)
                       (emit 'swap)  ;; The lower stack value is greater-or-equal
-                      (label LABEL1)
+                        (label LABEL1)
                       (emit 'pop))  ;; Throw away the lower stack value
 		    (emit-fixnum-init representation)
                     (emit-move-from-stack target representation))
                    ((and (java-long-type-p type1) (java-long-type-p type2))
-                    (compile-form arg1 'stack :long)
-                    (emit 'dup2)
-                    (compile-form arg2 'stack :long)
+                      (compile-form arg1 'stack :long)
+                      (emit 'dup2)
+                      (compile-form arg2 'stack :long)
                     (emit 'dup2_x2)
-                    (emit 'lcmp)
+                      (emit 'lcmp)
                     (let ((LABEL1 (gensym)))
                       (emit (if (eq op 'max) 'ifge 'ifle) LABEL1)
                       (emit 'dup2_x2) ;; pour-mans swap2
                       (emit 'pop2)
-                      (label LABEL1)
+                        (label LABEL1)
                       (emit 'pop2))
-                    (convert-long representation)
+                    (convert-representation :long representation)
                     (emit-move-from-stack target representation))
                    (t
                     (compile-form arg1 'stack nil)
@@ -6763,11 +6773,11 @@
                                             "isLessThanOrEqualTo"
                                             "isGreaterThanOrEqualTo")
                                         (lisp-object-arg-types 1) "Z")
-                      (let ((LABEL1 (gensym)))
-                        (emit 'ifeq LABEL1)
-                        (emit 'swap)
-                        (label LABEL1)
-                        (emit 'pop))
+                    (let ((LABEL1 (gensym)))
+                      (emit 'ifeq LABEL1)
+                      (emit 'swap)
+                      (label LABEL1)
+                      (emit 'pop))
                     (fix-boxing representation nil)
                     (emit-move-from-stack target representation))))))
          (t
@@ -6831,7 +6841,7 @@
                      (compile-form arg2 'stack :long)))
               (maybe-emit-clear-values arg1 arg2)
               (emit 'ladd)
-              (convert-long representation)
+              (convert-representation :long representation)
               (emit-move-from-stack target representation))
              ((eql arg2 1)
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
@@ -6890,7 +6900,7 @@
                  (emit 'l2i))
                 (:long)
                 (t
-                 (emit-box-long)))
+                 (convert-representation :long nil)))
               (emit-move-from-stack target representation))
              (t
 	      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
@@ -6915,7 +6925,7 @@
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							 arg2 'stack :long)
               (emit 'lsub)
-              (convert-long representation)
+              (convert-representation :long representation)
               (emit-move-from-stack target representation))
              ((fixnum-type-p type2)
 	      (compile-forms-and-maybe-emit-clear-values
@@ -7548,7 +7558,7 @@
                     (emit 'iconst_1))
                    (t
                     (emit 'lload (variable-register variable))
-                    (emit-box-long)))
+                    (convert-representation :long nil)))
                  (emit-move-from-stack target representation))
                 ((eq (variable-representation variable) :boolean)
                  (aver (variable-register variable))
@@ -7557,7 +7567,7 @@
                  (case representation
                    (:boolean)
                    (t
-                    (emit-box-boolean)))
+                    (convert-representation :boolean nil)))
                  (emit-move-from-stack target representation))
                 ((variable-register variable)
                  (aload (variable-register variable))
@@ -7775,7 +7785,7 @@
                 (emit 'l2i))
                (:long)
                (t
-                (emit-box-long)))
+                (convert-representation :long nil)))
              (emit-move-from-stack target representation)))
           ((eq (variable-representation variable) :boolean)
 	   (compile-forms-and-maybe-emit-clear-values value-form 'stack :boolean)
@@ -7787,7 +7797,7 @@
              (case representation
                (:boolean)
                (t
-                (emit-box-boolean)))
+                (convert-representation :boolean nil)))
              (emit-move-from-stack target representation)))
           (t
 	   (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)



From ehuelsmann at common-lisp.net  Mon Jan 26 21:40:22 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Jan 2009 21:40:22 +0000
Subject: [armedbear-cvs] r11593 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LRZBu-0005CA-0o@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 26 21:40:21 2009
New Revision: 11593

Log:
Optimize unboxing of booleans.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Jan 26 21:40:21 2009
@@ -211,6 +211,7 @@
 
 (defconstant +java-string+ "Ljava/lang/String;")
 (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
+(defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil")
 (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass")
 (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
 (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
@@ -840,15 +841,9 @@
 
 (defknown emit-unbox-boolean () t)
 (defun emit-unbox-boolean ()
-  (let ((LABEL1 (gensym))
-        (LABEL2 (gensym)))
-    (emit-push-nil)
-    (emit 'if_acmpeq LABEL1)
-    (emit 'iconst_1)
-    (emit 'goto LABEL2)
-    (label LABEL1)
-    (emit 'iconst_0)
-    (label LABEL2)))
+  (emit 'instanceof +lisp-nil-class+)
+  (emit 'iconst_1)
+  (emit 'ixor))  ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit
 
 (defknown fix-boxing (t t) t)
 (defun fix-boxing (required-representation derived-type)



From ehuelsmann at common-lisp.net  Mon Jan 26 21:54:05 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Jan 2009 21:54:05 +0000
Subject: [armedbear-cvs] r11594 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LRZPB-00061v-LB@common-lisp.net>

Author: ehuelsmann
Date: Mon Jan 26 21:54:03 2009
New Revision: 11594

Log:
Make DERIVE-TYPE support SINGLE-FLOAT and DOUBLE-FLOAT.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Jan 26 21:54:03 2009
@@ -6423,6 +6423,10 @@
          'NULL)
         ((integerp form)
          (list 'INTEGER form form))
+        ((typep form 'single-float)
+         'SINGLE-FLOAT)
+        ((typep form 'double-float)
+         'DOUBLE-FLOAT)
         ((characterp form)
          'CHARACTER)
         ((stringp form)



From mevenson at common-lisp.net  Tue Jan 27 17:11:48 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Tue, 27 Jan 2009 17:11:48 +0000
Subject: [armedbear-cvs] r11595 - trunk/abcl
Message-ID: <E1LRrTY-0005oE-W2@common-lisp.net>

Author: mevenson
Date: Tue Jan 27 17:11:46 2009
New Revision: 11595

Log:
Ignore .*.properties.

Modified:
   trunk/abcl/   (props changed)



From mevenson at common-lisp.net  Tue Jan 27 18:29:03 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Tue, 27 Jan 2009 18:29:03 +0000
Subject: [armedbear-cvs] r11596 - in trunk/abcl: . scripts test/lisp/abcl
	test/lisp/ansi
Message-ID: <E1LRsgJ-0001yP-6Q@common-lisp.net>

Author: mevenson
Date: Tue Jan 27 18:29:01 2009
New Revision: 11596

Log:
Invocation of ASDF tests from Lisp via instructions at top of 'abcl.asd' works.

Optimized 'build.xml' run time for typical (repeated) usage scenarios:
   o  downloading of 'junit.jar' based on presence on filesystem.  
   o  rebuilding of 'abcl.jar' based on explicit check via Ant

Removed automatic execution of ABCL-TESTS based on load.

Ant 'abcl.test' target not working in all situations.  Needs further
debugging.  Workaround: use the Lisp-based ASDF test entry point for now.

ANSI-TESTS-COMPILED ANSI-TESTS-INTERPRETED need a sibling directory
containing the GCL ANSI tests from
<svn://common-lisp.net/project/ansi-test/svn/trunk/ansi-tests>.  They
complain semi-intellibly if not found.




Removed:
   trunk/abcl/scripts/ansi-tests-compiled.lisp
   trunk/abcl/scripts/ansi-tests-interpreted.lisp
Modified:
   trunk/abcl/abcl.asd
   trunk/abcl/build.xml
   trunk/abcl/test/lisp/abcl/compiler-tests.lisp
   trunk/abcl/test/lisp/abcl/condition-tests.lisp
   trunk/abcl/test/lisp/abcl/file-system-tests.lisp
   trunk/abcl/test/lisp/abcl/java-tests.lisp
   trunk/abcl/test/lisp/abcl/math-tests.lisp
   trunk/abcl/test/lisp/abcl/misc-tests.lisp
   trunk/abcl/test/lisp/abcl/pathname-tests.lisp
   trunk/abcl/test/lisp/ansi/package.lisp

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Tue Jan 27 18:29:01 2009
@@ -1,6 +1,15 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP -*-
 ;;; $Id$
 
+;;;; To run:
+;;;;   
+#|
+cmd$ abcl 
+CL-USER(1): (progn (require 'asdf) 
+                   (asdf:oos 'asdf:load-op :abcl) 
+                   (asdf:oos 'asdf:test-op :ansi-test-compiled :force t))
+|#
+
 (require 'asdf)
 (defpackage :abcl-asdf
   (:use :cl :asdf))
@@ -8,7 +17,7 @@
 
 ;;; Wrapper for all ABCL ASDF definitions.
 (defsystem :abcl
-  :version "0.2.0")
+  :version "0.3.0")
 
 (defmethod perform :after ((o load-op) (c (eql (find-system 'abcl))))
   ;;; Additional test suite loads would go here.
@@ -20,12 +29,13 @@
 
 ;;; A collection of test suites for ABCL.
 (defsystem :test-abcl
-
   :version "0.3"
-  :depends-on (:ansi-test-compiled :ansi-test-interpreted))
+  :depends-on (:ansi-test-compiled :abcl-tests))
 
-(defmethod perform :after ((o test-op) (c (eql (find-system 'test-abcl))))
-  (asdf:oos 'asdf:load-op :ansi-test-interpreted :force t)
+(defmethod perform :after ((o load-op) (c (eql (find-system 'test-abcl))))
+  #+nil (asdf:oos 'asdf:test-op :cl-bench :force t)
+  #+nil (asdf:oos 'asdf:test-op :abcl-tests :force t)
+  #+nil (asdf:oos 'asdf:test-op :ansi-test-interpreted :force t)
   (asdf:oos 'asdf:load-op :ansi-test-compiled :force t))
 
 (defsystem :ansi-test :version "0.1" :components
@@ -35,31 +45,34 @@
 (defsystem :ansi-test-interpreted :version "0,1" :depends-on (ansi-test))
 (defsystem :ansi-test-compiled :version "0.1" :depends-on (ansi-test))
 
-
 (defsystem :abcl-tests
-  :version "1.0"
-  :components
-    ((:module rt :serial t  :pathname "test/lisp/abcl/" :components
-	      ((:file "rt-package") (:file "rt") (:file "test-utilities")))
-     (:module tests :depends-on (rt)
-	      :pathname "test/lisp/abcl/" :components
-	      ((:file "compiler-tests") 
-	       (:file "condition-tests")
-	       (:file "file-system-tests") 
-#+nil	       (:file "math-tests")
-	       (:file "java-tests")
-	       (:file "misc-tests")
-	       (:file "pathname-tests")))))
-
-(defmethod perform ((o test-op) (c (eql (find-system 'abcl-tests))))
-  "Invoke tests with:  (asdf:operate 'asdf:test-op :abcl-tests)."
-  (funcall (intern (symbol-name 'do-tests) :test)))
-
+   :version "1.0"
+   :components
+     ((:module rt :serial t  :pathname "test/lisp/abcl/" :components
+ 	      ((:file "rt-package") (:file "rt") (:file "test-utilities")))
+      (:module tests :depends-on (rt)
+ 	      :pathname "test/lisp/abcl/" :components
+ 	      ((:file "compiler-tests") 
+ 	       (:file "condition-tests")
+ 	       (:file "file-system-tests") 
+ #+nil	       (:file "math-tests")
+ 	       (:file "java-tests")
+ 	       (:file "misc-tests")
+ 	       (:file "pathname-tests")))))
+ 
+ (defmethod perform ((o test-op) (c (eql (find-system 'abcl-tests))))
+   "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-tests :force t)."
+   ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t
+   (funcall (intern (symbol-name 'do-tests) :test)))
+ 
 (defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-interpreted))))
+   "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-tests :force t)."
+   ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t
   (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
 	   :compile-tests nil))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-compiled))))
+  "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-test-compiled :force t)."
   (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
 	   :compile-tests t))
 

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Tue Jan 27 18:29:01 2009
@@ -141,7 +141,11 @@
     <target name="abcl.jsr-223.notice"
 	    depends="abcl.init"
 	    unless="abcl.jsr-223.p">
-      <echo>Notice: JSR-223 support won't be built since it is not supported, neither natively by your JVM nor by libraries in the CLASSPATH.</echo>
+      <echo>
+	Notice: JSR-223 support won't be built since it is not
+	        supported, neither natively by your JVM nor by 
+		libraries in the CLASSPATH.
+      </echo>
     </target>
 
     <target name="abcl.compile.java" 
@@ -232,7 +236,16 @@
       <echo>abcl.hostname: ${abcl.hostname}</echo>
     </target>
 
-    <target name="abcl.jar" depends="abcl.stamp">
+    <target name="abcl.jar.uptodate" depends="abcl.compile">
+      <uptodate property="abcl.jar.uptodate.p" targetfile="${abcl.jar.path}">
+	<srcfiles dir="${build.classes.dir}">
+	  <patternset refid="abcl.objects"/>
+	</srcfiles>
+      </uptodate>
+    </target>
+
+    <target name="abcl.jar" depends="abcl.stamp,abcl.jar.uptodate"
+	    unless="abcl.jar.uptodate.p">
       <mkdir dir="${dist.dir}"/>
       <loadfile property="abcl.version"
 		  srcFile="${abcl.version.path}"/>
@@ -433,14 +446,22 @@
       <pathelement location="${build.classes.dir}"/>
     </path>
 
-    <target name="abcl.test.pre-compile">
+    <target name="abcl.test.pre-compile" depends="abcl.ext"/>
+
+    <target name="abcl.ext.p">
+      <!--XXX generalize over enumeration of all contributions to abcl.ext -->
+      <available file="${junit-4.5.path}" property="abcl.ext.p"/>
+    </target>
+    <target name="abcl.ext" depends="abcl.ext.p" unless="abcl.ext.p">
+
       <mkdir dir="${abcl.ext.dir}"/>
       <get src="http://downloads.sourceforge.net/junit/junit-4.5.jar?modtime=1218209625"
 	   usetimestamp="true"
-	  dest="${junit-4.5.path}"/>
+	   dest="${junit-4.5.path}"/>
     </target>
 	
-    <target name="abcl.test.compile" depends="abcl.test.pre-compile,abcl.compile">
+    <target name="abcl.test.compile" 
+	    depends="abcl.test.pre-compile,abcl.compile">
       <mkdir dir="${abcl.test.classes.dir}"/>
       <javac destdir="${abcl.test.classes.dir}"
 	     classpathref="abcl.test.compile.classpath"
@@ -456,7 +477,8 @@
       <pathelement location="${abcl.test.classes.dir}"/>
     </path>
 
-    <target name="abcl.test" depends="abcl.test.java,abcl.test.lisp"/>
+    <target name="abcl.test" 
+	    depends="abcl.test.java,abcl.test.lisp"/>
 	
     <target name="abcl.test.java" depends="abcl.test.compile">
       <java fork="true"
@@ -466,9 +488,11 @@
       </java>
     </target>
 
-    <target name="abcl.test.lisp" depends="abcl.test.lisp.asdf"/>
+    <target name="abcl.test.lisp" 
+	    depends="abcl.test.lisp.asdf"/>
 
-    <target name="abcl.test.lisp.asdf" depends="abcl.jar,abcl.test.ansi.interpreted">
+    <target name="abcl.test.lisp.asdf" 
+	    depends="abcl.jar,abcl.test.ansi.compiled">
     </target>
 
     <target name="abcl.test.ansi.interpreted">
@@ -477,20 +501,27 @@
 	    classname="org.armedbear.lisp.Main">
  	<arg value="--noinit"/> 
 	<arg value="--load"/>
-	<arg line="${basedir}/scripts/ansi-tests-interpreted.lisp"/>
+	<arg line="${basedir}/test/lisp/ansi/ansi-tests-interpreted.lisp"/>
       </java>
     </target>
 
+    <property name="abcl.test.log.file"
+	      value="abcl.test.ansi.compiled.${version.src}"/>
+
     <target name="abcl.test.ansi.compiled">
+      <echo>Recording test output in ${abcl.test.log.file}.</echo>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="start"/>
       <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
 	<arg value="--noinit"/> 
 	<arg value="--load"/>
- 	<arg line="${basedir}/scripts/ansi-tests-compiled.lisp "/> 
+ 	<arg line="${basedir}/test/lisp/ansi/ansi-tests-compiled.lisp "/> 
       </java>
-    </target>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="stop"/>
+      <echo>Finished ecording test output in ${abcl.test.log.file}.</echo>
 
+    </target>
 
     <import file="netbeans-build.xml" optional="true"/> 
 <!--    <import file="j-build.xml" optional="true"/>  -->

Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/compiler-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/compiler-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -431,4 +431,3 @@
   :args (#.most-positive-java-long #.most-negative-java-long)
   :results #.most-positive-java-long)
 
-(do-tests)

Modified: trunk/abcl/test/lisp/abcl/condition-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/condition-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/condition-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -310,5 +310,3 @@
                              :format-arguments (list "The bear" "armed"))))
       (write-to-string c :escape nil)))
   "The bear is armed.")
-
-(do-tests)

Modified: trunk/abcl/test/lisp/abcl/file-system-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/file-system-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/file-system-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -513,5 +513,3 @@
          (delete-directory directory-namestring))
        )))
   t t t t)
-
-(do-tests)

Modified: trunk/abcl/test/lisp/abcl/java-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/java-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/java-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -433,7 +433,5 @@
        'illegal-argument-exception)))
   t)
 
-(do-tests)
-
 ;;#+allegro
 ;;(jlinker-end)

Modified: trunk/abcl/test/lisp/abcl/math-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/math-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/math-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -463,5 +463,3 @@
   #-(or cmu sbcl)
   (signals-error (read-from-string "1.0f-1000") 'reader-error)
   t)
-
-(do-tests)

Modified: trunk/abcl/test/lisp/abcl/misc-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/misc-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/misc-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -98,5 +98,3 @@
   (read-from-string "(1 2 #+nil #k(3 4))")
   (1 2)
   19)
-
-(do-tests)

Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/pathname-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp	Tue Jan 27 18:29:01 2009
@@ -1654,5 +1654,3 @@
            #-windows "/foo"
            #+windows "\\foo")
   t)
-
-(do-tests)

Modified: trunk/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/package.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/package.lisp	Tue Jan 27 18:29:01 2009
@@ -16,21 +16,28 @@
 (defun run (&key (compile-tests nil)) 
   "Run the ANSI-TESTS suite, found in *ANSI-TESTS-DIRECTORY*.
 Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL."
-  (let ((original-pathname-defaults *default-pathname-defaults*)
+  (let* ((original-pathname-defaults *default-pathname-defaults*)
 	(ansi-tests-directory *ansi-tests-directory*)
-	(boot-file (if compile-tests "compileit.lsp" "doit.lsp")))
+	(boot-file (if compile-tests "compileit.lsp" "doit.lsp"))
+	(message (format nil "Invocation of '~A' in ~A"
+			       boot-file ansi-tests-directory)))
     (handler-case 
 	(progn
 	  (setf  *default-pathname-defaults*
 		 (merge-pathnames ansi-tests-directory 
 				  *default-pathname-defaults*))
-	  (warn 
-	   (format nil "Speculative invocation of '~A' in ~A follows."
-		   boot-file
-		   ansi-tests-directory))
-;; XXX -- what to invoke on win32?
-;;	  (run-shell-command "make clean" :directory ansi-tests-directory)
-	  (time (load boot-file)))
+	  (format t "--->  ~A begins.~%" message)
+	  (format t "Invoking ABCL hosted on ~A ~A.~%" 
+		  (software-type) (software-version))
+	  (if (find :unix *features*)
+	      (run-shell-command "cd ~A; make clean" ansi-tests-directory)
+	      ;; XXX -- what to invoke on win32?  Please verify
+	      (run-shell-command 
+	       (format nil ("~A~%~A")
+		       (format nil "cd ~A" *ansi-tests-directory*)
+		       (format nil "erase *.cls *.abcl"))))
+	  (time (load boot-file))
+	  (format t "<--- ~A ends.~%" message))
       (file-error (e)
 		(error 
 		 (format nil



From astalla at common-lisp.net  Tue Jan 27 20:20:33 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Tue, 27 Jan 2009 20:20:33 +0000
Subject: [armedbear-cvs] r11597 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LRuQD-0007VS-Gi@common-lisp.net>

Author: astalla
Date: Tue Jan 27 20:20:31 2009
New Revision: 11597

Log:
Fixed URL decoding bug in loadCompiledFunction using 
java.net.URLDecoder.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Lisp.java

Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java	Tue Jan 27 20:20:31 2009
@@ -40,6 +40,7 @@
 import java.lang.reflect.Constructor;
 import java.math.BigInteger;
 import java.net.URL;
+import java.net.URLDecoder;
 import java.util.Hashtable;
 import java.util.zip.ZipEntry;
 import java.util.zip.ZipFile;
@@ -999,24 +1000,8 @@
                             // "/C:/Documents%20and%20Settings/peter/Desktop/j.jar"
                             if (zipFileName.length() > 0 && zipFileName.charAt(0) == '/')
                               zipFileName = zipFileName.substring(1);
-                            // "C:/Documents%20and%20Settings/peter/Desktop/j.jar"
-                            int i = zipFileName.indexOf("%20");
-                            if (i >= 0)
-                              {
-                                int begin = 0;
-                                FastStringBuffer sb = new FastStringBuffer();
-                                while (i >= 0)
-                                  {
-                                    sb.append(zipFileName.substring(begin, i));
-                                    sb.append(' ');
-                                    begin = i + 3;
-                                    i = zipFileName.indexOf("%20", begin);
-                                  }
-                                sb.append(zipFileName.substring(begin));
-                                zipFileName = sb.toString();
-                                // "C:/Documents and Settings/peter/Desktop/j.jar"
-                              }
-                          }
+			  }
+			zipFileName = URLDecoder.decode(zipFileName, "UTF-8");
                         ZipFile zipFile = new ZipFile(zipFileName);
                         try
                           {



From mevenson at common-lisp.net  Wed Jan 28 11:29:31 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Wed, 28 Jan 2009 11:29:31 +0000
Subject: [armedbear-cvs] r11598 - trunk/abcl/test/lisp/ansi
Message-ID: <E1LS8br-00056E-1t@common-lisp.net>

Author: mevenson
Date: Wed Jan 28 11:29:27 2009
New Revision: 11598

Log:
Added (somehow) missing GCL ANSI test ASDF loading wrappers.


Added:
   trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp   (contents, props changed)
   trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp   (contents, props changed)
Modified:
   trunk/abcl/test/lisp/ansi/package.lisp

Added: trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp	Wed Jan 28 11:29:27 2009
@@ -0,0 +1,6 @@
+(require 'asdf)
+(asdf:oos 'asdf:load-op :abcl)
+(asdf:oos 'asdf:load-op :test-abcl)
+(asdf:oos 'asdf:load-op :ansi-abcl-compiled :force t)
+(asdf:oos 'asdf:test-op :ansi-test-compiled :force t)
+(ext:exit)
\ No newline at end of file

Added: trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp	Wed Jan 28 11:29:27 2009
@@ -0,0 +1,5 @@
+(require 'asdf)
+(asdf:oos 'asdf:load-op :abcl)
+(asdf:oos 'asdf:load-op :test-abcl)
+(asdf:oos 'asdf:test-op :ansi-test-interpreted :force t)
+(ext:exit)

Modified: trunk/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/package.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/package.lisp	Wed Jan 28 11:29:27 2009
@@ -47,8 +47,7 @@
 and set the value of *ANSI-TESTS-DIRECTORY* to that location."
 		 ansi-tests-directory e 
 		 *ansi-tests-master-source-location*))))
-    (setf *default-pathname-defaults*
-	  original-pathname-defaults)))
+    (setf *default-pathname-defaults* original-pathname-defaults)))
 		   
 	     
 



From mevenson at common-lisp.net  Thu Jan 29 16:00:11 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Thu, 29 Jan 2009 16:00:11 +0000
Subject: [armedbear-cvs] r11599 - in trunk/abcl: . test/lisp/abcl
	test/lisp/ansi
Message-ID: <E1LSZJL-0001t8-6i@common-lisp.net>

Author: mevenson
Date: Thu Jan 29 16:00:07 2009
New Revision: 11599

Log:
Use HANDLER-CASE for ANSI tests to quit invoking Lisp if an error in generated.

Further incremental work on ABCL-TEST-LISP (aka the internal ABCL
tests) necessitated by the fact that both it and the ANSI tests use
the REGRESSION-TEST framework which doesn't work well in the same Lisp
instances.  Trying to repackage this correctly, but it needs more work.




Modified:
   trunk/abcl/abcl.asd
   trunk/abcl/test/lisp/abcl/compiler-tests.lisp
   trunk/abcl/test/lisp/abcl/condition-tests.lisp
   trunk/abcl/test/lisp/abcl/file-system-tests.lisp
   trunk/abcl/test/lisp/abcl/java-tests.lisp
   trunk/abcl/test/lisp/abcl/math-tests.lisp
   trunk/abcl/test/lisp/abcl/misc-tests.lisp
   trunk/abcl/test/lisp/abcl/pathname-tests.lisp
   trunk/abcl/test/lisp/abcl/rt-package.lisp
   trunk/abcl/test/lisp/abcl/rt.lisp
   trunk/abcl/test/lisp/abcl/test-utilities.lisp
   trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp
   trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp
   trunk/abcl/test/lisp/ansi/package.lisp

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Thu Jan 29 16:00:07 2009
@@ -1,23 +1,13 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP -*-
 ;;; $Id$
 
-;;;; To run:
-;;;;   
-#|
-cmd$ abcl 
-CL-USER(1): (progn (require 'asdf) 
-                   (asdf:oos 'asdf:load-op :abcl) 
-                   (asdf:oos 'asdf:test-op :ansi-test-compiled :force t))
-|#
-
 (require 'asdf)
 (defpackage :abcl-asdf
   (:use :cl :asdf))
 (in-package :abcl-asdf)
 
 ;;; Wrapper for all ABCL ASDF definitions.
-(defsystem :abcl
-  :version "0.3.0")
+(defsystem :abcl :version "0.3.0")
 
 (defmethod perform :after ((o load-op) (c (eql (find-system 'abcl))))
   ;;; Additional test suite loads would go here.
@@ -25,61 +15,49 @@
 
 (defmethod perform ((o test-op) (c (eql (find-system 'abcl))))
   ;;; Additional test suite invocations would go here.
-  (asdf:oos 'asdf:test-op :ansi-test-compiled :force t))
+  (asdf:oos 'asdf:test-op :ansi-compiled :force t))
 
 ;;; A collection of test suites for ABCL.
 (defsystem :test-abcl
   :version "0.3"
-  :depends-on (:ansi-test-compiled :abcl-tests))
+  :depends-on (:ansi-compiled #+nil :abcl-tests))
 
 (defmethod perform :after ((o load-op) (c (eql (find-system 'test-abcl))))
   #+nil (asdf:oos 'asdf:test-op :cl-bench :force t)
-  #+nil (asdf:oos 'asdf:test-op :abcl-tests :force t)
-  #+nil (asdf:oos 'asdf:test-op :ansi-test-interpreted :force t)
-  (asdf:oos 'asdf:load-op :ansi-test-compiled :force t))
+  (asdf:oos 'asdf:load-op :abcl-test-lisp :force t)
+  (asdf:oos 'asdf:load-op :ansi-compiled :force t)
+  (asdf:oos 'asdf:load-op :ansi-interpreted :force t))
 
-(defsystem :ansi-test :version "0.1" :components
+(defsystem :ansi-test :version "1.0" :components
      ;;; GCL ANSI test suite.
      ((:module ansi-tests :pathname "test/lisp/ansi/" :components
 	       ((:file "package")))))
-(defsystem :ansi-test-interpreted :version "0,1" :depends-on (ansi-test))
-(defsystem :ansi-test-compiled :version "0.1" :depends-on (ansi-test))
 
-(defsystem :abcl-tests
-   :version "1.0"
-   :components
-     ((:module rt :serial t  :pathname "test/lisp/abcl/" :components
- 	      ((:file "rt-package") (:file "rt") (:file "test-utilities")))
-      (:module tests :depends-on (rt)
- 	      :pathname "test/lisp/abcl/" :components
- 	      ((:file "compiler-tests") 
- 	       (:file "condition-tests")
- 	       (:file "file-system-tests") 
- #+nil	       (:file "math-tests")
- 	       (:file "java-tests")
- 	       (:file "misc-tests")
- 	       (:file "pathname-tests")))))
- 
- (defmethod perform ((o test-op) (c (eql (find-system 'abcl-tests))))
-   "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-tests :force t)."
+(defsystem :ansi-interpreted :version "1.0" :depends-on (ansi-test))
+(defmethod perform ((o test-op) (c (eql (find-system 'ansi-interpreted))))
+   "Invoke tests with:  (asdf:oos 'asdf:test-op :ansi-interpreted :force t)."
    ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t
-   (funcall (intern (symbol-name 'do-tests) :test)))
- 
-(defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-interpreted))))
-   "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-tests :force t)."
-   ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t
-  (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
+  (funcall (intern (symbol-name 'run) :ansi.test.ansi)
 	   :compile-tests nil))
 
-(defmethod perform ((o test-op) (c (eql (find-system 'ansi-test-compiled))))
-  "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-test-compiled :force t)."
-  (funcall (intern (symbol-name 'run) :abcl.tests.ansi-tests)
+(defsystem :ansi-compiled :version "1.0" :depends-on (ansi-test))
+(defmethod perform ((o test-op) (c (eql (find-system 'ansi-compiled))))
+  "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-compiled :force t)."
+  (funcall (intern (symbol-name 'run) :abcl.test.ansi)
 	   :compile-tests t))
 
+(defsystem :abcl-test-lisp :version "1.0" :components
+	   ((:module package  :pathname "test/lisp/abcl/" :components
+		     ((:file "package")))))
+(defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp))))
+   "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-tests :force t)."
+   ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t
+   (funcall (intern (symbol-name 'run) :abcl.test.lisp)))
+ 
 ;;; Build ABCL from a Lisp.
+;;; aka the "Lisp-hosted build system"
 ;;; Works for: abcl, sbcl, clisp, cmu, lispworks, allegro, openmcl
-(defsystem :build-abcl 
-  :components 
+(defsystem :build-abcl :components 
 	   ((:module build :pathname ""  :components
 		     ((:file "build-abcl") 
 		      (:file "customizations" :depends-on ("build-abcl"))))))

Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/compiler-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/compiler-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -20,9 +20,7 @@
 #+abcl
 (require '#:jvm)
 
-(load (merge-pathnames "test-utilities.lisp" *load-truename*))
-
-(in-package #:test)
+(in-package #:abcl.test.lisp)
 
 (defconstant most-positive-java-long 9223372036854775807)
 (defconstant most-negative-java-long -9223372036854775808)

Modified: trunk/abcl/test/lisp/abcl/condition-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/condition-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/condition-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -18,7 +18,7 @@
 
 (load (merge-pathnames "test-utilities.lisp" *load-truename*))
 
-(in-package #:test)
+(in-package #:abcl.test.lisp)
 
 (defun filter (string)
   "If STRING is unreadable, return \"#<>\"; otherwise return STRING unchanged."

Modified: trunk/abcl/test/lisp/abcl/file-system-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/file-system-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/file-system-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -19,9 +19,7 @@
 #+sbcl
 (require '#:sb-posix)
 
-(load "test-utilities.lisp")
-
-(in-package #:test)
+(in-package #:abcl.test.lisp)
 
 (export '(pathnames-equal-p run-shell-command copy-file make-symbolic-link
           touch make-temporary-directory delete-directory-and-files))

Modified: trunk/abcl/test/lisp/abcl/java-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/java-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/java-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -17,12 +17,10 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
-(load (merge-pathnames "test-utilities.lisp" *load-truename*))
+(in-package #:abcl.test.lisp)
 
-(in-package #:test)
-
-#+abcl
-(use-package '#:java)
+;#+abcl
+;(use-package '#:java)
 
 #+allegro
 (require :jlinker)

Modified: trunk/abcl/test/lisp/abcl/math-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/math-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/math-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -19,9 +19,7 @@
 
 ;;; Some of these tests are based on tests in the CLISP test suite.
 
-(load "test-utilities.lisp")
-
-(in-package #:test)
+(in-package #:abcl.test.lisp)
 
 #+(or abcl cmu sbcl)
 (defmacro set-floating-point-modes (&rest args)

Modified: trunk/abcl/test/lisp/abcl/misc-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/misc-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/misc-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -17,9 +17,7 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
-(load (merge-pathnames "test-utilities.lisp" *load-truename*))
-
-(in-package #:test)
+(in-package #:abcl.test.lisp)
 
 (deftest dotimes.1
   (progn

Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/pathname-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp	Thu Jan 29 16:00:07 2009
@@ -17,9 +17,7 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
-(load (merge-pathnames "test-utilities.lisp" *load-truename*))
-
-(in-package #:test)
+(in-package #:abcl.test.lisp)
 
 (defun check-physical-pathname (pathname expected-directory expected-name expected-type)
   (let* ((directory (pathname-directory pathname))

Modified: trunk/abcl/test/lisp/abcl/rt-package.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/rt-package.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/rt-package.lisp	Thu Jan 29 16:00:07 2009
@@ -26,10 +26,10 @@
      #:disable-note
      ))
  |#
- (let* ((name (symbol-name :regression-test))
+ (let* ((name (symbol-name :abcl-regression-test))
 	(pkg (find-package name)))
    (unless pkg (setq pkg (make-package name
-				       :nicknames (mapcar #'symbol-name '(:rtest #-lispworks :rt))
+				       :nicknames (mapcar #'symbol-name '(:abcl-rtest #-lispworks :abcl-rt))
 				       :use '(#-wcl :cl #+wcl :lisp)
 				       )))
    (let ((*package* pkg))

Modified: trunk/abcl/test/lisp/abcl/rt.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/rt.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/rt.lisp	Thu Jan 29 16:00:07 2009
@@ -24,7 +24,7 @@
 ;This was the December 19, 1990 version of the regression tester, but
 ;has since been modified.
 
-(in-package :regression-test)
+(in-package :abcl-regression-test)
 
 (declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
 (declaim (type list *entries*))

Modified: trunk/abcl/test/lisp/abcl/test-utilities.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/test-utilities.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/test-utilities.lisp	Thu Jan 29 16:00:07 2009
@@ -24,18 +24,15 @@
 #+(and lispworks win32)
 (pushnew :windows *features*)
 
-(unless (member "RT" *modules* :test #'string=)
+(unless (member "ABCL-RT" *modules* :test #'string=)
   (load (merge-pathnames "rt-package.lisp" *load-truename*))
   (load #+abcl (compile-file-if-needed (merge-pathnames "rt.lisp" *load-truename*))
         ;; Force compilation to avoid fasl name conflict between SBCL and
         ;; Allegro.
         #-abcl (compile-file (merge-pathnames "rt.lisp" *load-truename*)))
-  (provide "RT"))
+  (provide "ABCL-RT"))
 
-(unless (find-package '#:test)
-  (defpackage #:test (:use #:cl #:regression-test)))
-
-(in-package #:regression-test)
+(in-package #:abcl-regression-test)
 
 (export '(signals-error))
 
@@ -45,6 +42,6 @@
        (condition (c) (typep c ,error-name))
        (:no-error (&rest ignored) (declare (ignore ignored)) nil))))
 
-(rem-all-tests)
+#+nil (rem-all-tests)
 
-(setf *expected-failures* nil)
+#+nil (setf *expected-failures* nil)

Modified: trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp	Thu Jan 29 16:00:07 2009
@@ -1,6 +1,10 @@
 (require 'asdf)
-(asdf:oos 'asdf:load-op :abcl)
-(asdf:oos 'asdf:load-op :test-abcl)
-(asdf:oos 'asdf:load-op :ansi-abcl-compiled :force t)
-(asdf:oos 'asdf:test-op :ansi-test-compiled :force t)
-(ext:exit)
\ No newline at end of file
+(handler-case 
+    (progn
+      (asdf:oos 'asdf:load-op :abcl :force t)
+      (asdf:oos 'asdf:test-op :ansi-compiled :force t))
+  (t (e) (warn "Exiting after catching ~A" e)))
+(ext:exit)
+  
+      
+

Modified: trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp	Thu Jan 29 16:00:07 2009
@@ -1,5 +1,10 @@
 (require 'asdf)
-(asdf:oos 'asdf:load-op :abcl)
-(asdf:oos 'asdf:load-op :test-abcl)
-(asdf:oos 'asdf:test-op :ansi-test-interpreted :force t)
+(handler-case 
+    (progn
+      (asdf:oos 'asdf:load-op :abcl :force t)
+      (asdf:oos 'asdf:test-op :ansi-interpreted :force t))
+  (t (e) (warn "Exiting after catching ~A" e)))
 (ext:exit)
+  
+      
+

Modified: trunk/abcl/test/lisp/ansi/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/package.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/package.lisp	Thu Jan 29 16:00:07 2009
@@ -1,9 +1,9 @@
-(defpackage :abcl.tests.ansi-tests
+(defpackage :abcl.test.ansi
   (:use :cl :asdf)
-  (:nicknames "ansi-tests" "abcl-ansi-tests")
+  (:nicknames "ansi-tests" "abcl-ansi-tests" "gcl-ansi")
   (:export :run))
 
-(in-package :abcl.tests.ansi-tests)
+(in-package :abcl.test.ansi)
 
 (defparameter *ansi-tests-master-source-location*
   "<svn://common-lisp.net/project/ansi-test/svn/trunk/ansi-tests>")  
@@ -14,26 +14,26 @@
    (asdf:component-pathname (asdf:find-system :abcl))))
 
 (defun run (&key (compile-tests nil)) 
-  "Run the ANSI-TESTS suite, found in *ANSI-TESTS-DIRECTORY*.
+  "Run the ANSI-TESTS suite, to be found in *ANSI-TESTS-DIRECTORY*.
 Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL."
-  (let* ((original-pathname-defaults *default-pathname-defaults*)
-	(ansi-tests-directory *ansi-tests-directory*)
-	(boot-file (if compile-tests "compileit.lsp" "doit.lsp"))
-	(message (format nil "Invocation of '~A' in ~A"
-			       boot-file ansi-tests-directory)))
+  (let* ((ansi-tests-directory 
+	  *ansi-tests-directory*)
+	 (boot-file 
+	  (if compile-tests "compileit.lsp" "doit.lsp"))
+	 (message 
+	  (format nil "Invocation of '~A' in ~A" boot-file ansi-tests-directory)))
     (handler-case 
-	(progn
-	  (setf  *default-pathname-defaults*
-		 (merge-pathnames ansi-tests-directory 
-				  *default-pathname-defaults*))
+	(progv 
+	    '(*default-pathname-defaults*) 
+	    `(,(merge-pathnames *ansi-tests-directory* *default-pathname-defaults*))
 	  (format t "--->  ~A begins.~%" message)
 	  (format t "Invoking ABCL hosted on ~A ~A.~%" 
 		  (software-type) (software-version))
 	  (if (find :unix *features*)
 	      (run-shell-command "cd ~A; make clean" ansi-tests-directory)
-	      ;; XXX -- what to invoke on win32?  Please verify
+	      ;; XXX -- what to invoke on win32?  Untested:
 	      (run-shell-command 
-	       (format nil ("~A~%~A")
+	       (format nil "~A~%~A"
 		       (format nil "cd ~A" *ansi-tests-directory*)
 		       (format nil "erase *.cls *.abcl"))))
 	  (time (load boot-file))
@@ -46,8 +46,8 @@
 To resolve, please locally obtain ~A, 
 and set the value of *ANSI-TESTS-DIRECTORY* to that location."
 		 ansi-tests-directory e 
-		 *ansi-tests-master-source-location*))))
-    (setf *default-pathname-defaults* original-pathname-defaults)))
+		 *ansi-tests-master-source-location*))))))
+
 		   
 	     
 



From ehuelsmann at common-lisp.net  Thu Jan 29 20:00:27 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 29 Jan 2009 20:00:27 +0000
Subject: [armedbear-cvs] r11600 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LSd3r-0004wM-83@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan 29 20:00:24 2009
New Revision: 11600

Log:
Add more opcodes to the list; update stack effect information.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/opcodes.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Jan 29 20:00:24 2009
@@ -1040,12 +1040,18 @@
                  95 ; swap
                  96 ; iadd
                  97 ; ladd
+                 98 ; fadd
+                 99 ; dadd
                  100 ; isub
                  101 ; lsub
+                 102 ; fsub
+                 103 ; dsub
                  104 ; imul
                  105 ; lmul
                  116 ; ineg
                  117 ; lneg
+                 118 ; fneg
+                 119 ; dneg
                  120 ; ishl
                  121 ; lshl
                  122 ; ishr
@@ -1057,6 +1063,7 @@
                  130 ; ixor
                  131 ; lxor
                  133 ; i2l
+                 134 ; i2f
                  136 ; l2i
                  148 ; lcmp
                  153 ; ifeq
@@ -6804,14 +6811,16 @@
             (arg2 (%cadr args))
             (type1 (derive-compiler-type arg1))
             (type2 (derive-compiler-type arg2))
-            (result-type (derive-compiler-type form)))
-;;        (let ((*print-structure* nil))
-;;          (format t "~&p2-plus arg1 = ~S~%" arg1)
-;;          (format t "p2-plus arg2 = ~S~%" arg2))
-;;        (format t "~&p2-plus type1 = ~S~%" type1)
-;;        (format t "p2-plus type2 = ~S~%" type2)
-;;        (format t "p2-plus result-type = ~S~%" result-type)
-;;        (format t "p2-plus representation = ~S~%" representation)
+            (result-type (derive-compiler-type form))
+            (result-rep (type-representation result-type)))
+;;         (let ((*print-structure* nil))
+;;           (format t "~&p2-plus arg1 = ~S~%" arg1)
+;;           (format t "p2-plus arg2 = ~S~%" arg2))
+;;         (format t "~&p2-plus type1 = ~S~%" type1)
+;;         (format t "p2-plus type2 = ~S~%" type2)
+;;         (format t "p2-plus result-type = ~S~%" result-type)
+;;         (format t "p2-plus result-rep = ~S~%" result-rep)
+;;         (format t "p2-plus representation = ~S~%" representation)
        (cond ((and (numberp arg1) (numberp arg2))
               (compile-constant (+ arg1 arg2) target representation))
              ((and (numberp arg1) (eql arg1 0))
@@ -6831,7 +6840,7 @@
               (cond ((fixnum-type-p type1)
                      (compile-form arg1 'stack :int)
                      (emit 'i2l))
-                    (t
+                      (t
                      (compile-form arg1 'stack :long)))
               (cond ((fixnum-type-p type2)
                      (compile-form arg2 'stack :int)
@@ -6898,7 +6907,7 @@
                 (:int
                  (emit 'l2i))
                 (:long)
-                (t
+                      (t
                  (convert-representation :long nil)))
               (emit-move-from-stack target representation))
              (t

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Thu Jan 29 20:00:24 2009
@@ -154,8 +154,8 @@
 (define-opcode dadd 99 1 -2)
 (define-opcode isub 100 1 -1)
 (define-opcode lsub 101 1 -2)
-(define-opcode fsub 102 1 nil)
-(define-opcode dsub 103 1 nil)
+(define-opcode fsub 102 1 -1)
+(define-opcode dsub 103 1 -2)
 (define-opcode imul 104 1 -1)
 (define-opcode lmul 105 1 -2)
 (define-opcode fmul 106 1 -1)
@@ -170,8 +170,8 @@
 (define-opcode drem 115 1 nil)
 (define-opcode ineg 116 1 0)
 (define-opcode lneg 117 1 0)
-(define-opcode fneg 118 1 nil)
-(define-opcode dneg 119 1 nil)
+(define-opcode fneg 118 1 0)
+(define-opcode dneg 119 1 0)
 (define-opcode ishl 120 1 -1)
 (define-opcode lshl 121 1 -1)
 (define-opcode ishr 122 1 -1)



From ehuelsmann at common-lisp.net  Thu Jan 29 20:10:45 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 29 Jan 2009 20:10:45 +0000
Subject: [armedbear-cvs] r11601 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LSdDp-0005BS-0O@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan 29 20:10:44 2009
New Revision: 11601

Log:
Only compile one or the other argument to an :int.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Jan 29 20:10:44 2009
@@ -6860,7 +6860,7 @@
              ((or (fixnum-type-p type1) (fixnum-type-p type2))
 	      (compile-forms-and-maybe-emit-clear-values
                     arg1 'stack (when (fixnum-type-p type1) :int)
-                    arg2 'stack (when (fixnum-type-p type2) :int))
+                    arg2 'stack (when (null (fixnum-type-p type1)) :int))
               (when (fixnum-type-p type1)
                 (emit 'swap))
               (emit-invokevirtual +lisp-object-class+ "add"



From ehuelsmann at common-lisp.net  Thu Jan 29 20:23:51 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 29 Jan 2009 20:23:51 +0000
Subject: [armedbear-cvs] r11602 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LSdQV-0005wF-Q8@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan 29 20:23:51 2009
New Revision: 11602

Log:
Implement generic type-representation derivations and conversions;
shorten P2-MINUS and P2-PLUS implementations by using them.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Jan 29 20:23:51 2009
@@ -499,6 +499,28 @@
       (setf pretty-string (concatenate 'string pretty-string "[]")))
     pretty-string))
 
+(defvar type-representations '((:int fixnum)
+                               (:long (integer #.most-negative-java-long
+                                               #.most-positive-java-long))
+                               (:float single-float)
+                               (:double double-float)
+                               (:char base-char character)
+                               (:boolean boolean)
+                               )
+  "Lists the widest Lisp types to be stored in each of the Java primitives
+supported (and used) by the compiler.")
+
+(defun type-representation (the-type)
+  "Converts a type specification or compiler type into a representation."
+  (do* ((types type-representations (cdr types)))
+       ((endp types) nil)
+    (do* ((type-list (cdr (car types)) (cdr type-list))
+          (type (car type-list) (car type-list)))
+         ((endp type-list))
+      (when (or (subtypep the-type type)
+                (compiler-subtypep the-type (make-compiler-type type)))
+        (return-from type-representation (caar types))))))
+
 ;;                     source type /
 ;;                         targets   :boolean :char    :int :long :float :double
 (defvar rep-conversion '((:boolean . #( NIL    :err    :err  :err  :err   :err))
@@ -6831,25 +6853,21 @@
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack representation
 							 arg2 nil nil)
               (emit-move-from-stack target representation))
-             ((and (fixnum-type-p type1) (fixnum-type-p type2))
-	      (fixnum-result-plus/minus target representation result-type 
-					arg1 arg2 'iadd 'ladd))
-             ((and (java-long-type-p type1)
-                   (java-long-type-p type2)
-                   (java-long-type-p result-type))
-              (cond ((fixnum-type-p type1)
-                     (compile-form arg1 'stack :int)
-                     (emit 'i2l))
+             (result-rep
+              (compile-forms-and-maybe-emit-clear-values
+                        arg1 'stack result-rep
+                        arg2 'stack result-rep)
+              (emit (case result-rep
+                      (:int 'iadd)
+                      (:long 'ladd)
+                      (:float 'fadd)
+                      (:double 'dadd)
                       (t
-                     (compile-form arg1 'stack :long)))
-              (cond ((fixnum-type-p type2)
-                     (compile-form arg2 'stack :int)
-                     (emit 'i2l))
-                    (t
-                     (compile-form arg2 'stack :long)))
-              (maybe-emit-clear-values arg1 arg2)
-              (emit 'ladd)
-              (convert-representation :long representation)
+                       (sys::format
+                        t "p2-plus: Unexpected result-rep ~S for form ~S."
+                        result-rep form)
+                       (assert nil))))
+              (convert-representation result-rep representation)
               (emit-move-from-stack target representation))
              ((eql arg2 1)
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
@@ -6880,35 +6898,24 @@
   (case (length form)
     (2
      (let* ((arg (%cadr form))
-            (type (derive-compiler-type arg)))
-       (cond ((eql (fixnum-constant-value type) 0)
-              (case representation
-                (:int
-                 (emit 'iconst_0))
-                (:long
-                 (emit 'lconst_0))
-                (t
-                 (emit 'getstatic +lisp-fixnum-class+ "ZERO" +lisp-fixnum+)))
+            (type (derive-compiler-type form))
+            (type-rep (type-representation type)))
+       (cond ((numberp arg)
+              (compile-constant (- arg) 'stack representation)
               (emit-move-from-stack target representation))
-             ((and (fixnum-type-p type)
-                   (integer-type-low type)
-                   (> (integer-type-low type) most-negative-fixnum))
-	      (new-fixnum (null representation))
-              (compile-form arg 'stack :int)
-              (emit 'ineg)
-	      (emit-fixnum-init representation)
-              (emit-move-from-stack target representation))
-             ((and (java-long-type-p type)
-                   (integer-type-low type)
-                   (> (integer-type-low type) most-negative-java-long))
-              (compile-form arg 'stack :long)
-              (emit 'lneg)
-              (case representation
-                (:int
-                 (emit 'l2i))
-                (:long)
+             (type-rep
+              (compile-form arg 'stack type-rep)
+              (emit (case type-rep
+                      (:int    'ineg)
+                      (:long   'lneg)
+                      (:float  'fneg)
+                      (:double 'dneg)
                       (t
-                 (convert-representation :long nil)))
+                       (sys::format t
+                                    "p2-minus: unsupported rep (~S) for '~S'~%"
+                                    type-rep form)
+                       (assert nil))))
+              (convert-representation type-rep representation)
               (emit-move-from-stack target representation))
              (t
 	      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
@@ -6920,20 +6927,25 @@
      (let* ((args (cdr form))
             (arg1 (first args))
             (arg2 (second args))
-            (type1 (derive-compiler-type arg1))
             (type2 (derive-compiler-type arg2))
-            (result-type (derive-compiler-type form)))
+            (result-type (derive-compiler-type form))
+            (result-rep (type-representation result-type)))
        (cond ((and (numberp arg1) (numberp arg2))
               (compile-constant (- arg1 arg2) target representation))
-             ((and (fixnum-type-p type1) (fixnum-type-p type2))
-	      (fixnum-result-plus/minus target representation result-type 
-					arg1 arg2 'isub 'lsub))
-             ((and (java-long-type-p type1) (java-long-type-p type2)
-                   (java-long-type-p result-type))
-	      (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
-							 arg2 'stack :long)
-              (emit 'lsub)
-              (convert-representation :long representation)
+             (result-rep
+	      (compile-forms-and-maybe-emit-clear-values
+                        arg1 'stack result-rep
+                        arg2 'stack result-rep)
+              (emit (case result-rep
+                      (:int 'isub)
+                      (:long 'lsub)
+                      (:float 'fsub)
+                      (:double 'dsub)
+                      (t
+                       (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%"
+                                     result-rep form)
+                       (assert nil))))
+              (convert-representation result-rep representation)
               (emit-move-from-stack target representation))
              ((fixnum-type-p type2)
 	      (compile-forms-and-maybe-emit-clear-values



From ehuelsmann at common-lisp.net  Thu Jan 29 22:30:49 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 29 Jan 2009 22:30:49 +0000
Subject: [armedbear-cvs] r11603 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LSfPN-0003TJ-Nz@common-lisp.net>

Author: ehuelsmann
Date: Thu Jan 29 22:30:47 2009
New Revision: 11603

Log:
Use generic representation conversions instead of enumerating in line.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Jan 29 22:30:47 2009
@@ -7533,61 +7533,24 @@
                  (compile-special-reference (variable-name variable) target representation))
                 ((eq (variable-representation variable) :int)
                  (aver (variable-register variable))
-                 (case representation
-                   (:int
-                    (emit 'iload (variable-register variable)))
-                   (:char
-                    (sys::%format t "compile-var-ref :char case~%")
-                    (aver nil))
-                   (:long
-                    (emit 'iload (variable-register variable))
-                    (emit 'i2l))
-                   (:boolean
-                    (emit 'iconst_1))
-                   (t
-		    (new-fixnum)
-                    (emit 'iload (variable-register variable))
-                    (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
+                 (emit 'iload (variable-register variable))
+                 (convert-representation :int representation)
                  (emit-move-from-stack target representation))
                 ((eq (variable-representation variable) :char)
-                 (case representation
-                   (:char
-                    (aver (variable-register variable))
-                    (emit 'iload (variable-register variable)))
-                   (:boolean
-                    (emit 'iconst_1))
-                   (t
-                    (emit 'new +lisp-character-class+)
-                    (emit 'dup)
-                    (aver (variable-register variable))
-                    (emit 'iload (variable-register variable))
-                    (emit-invokespecial-init +lisp-character-class+ '("C"))))
+                 (aver (variable-register variable))
+                 (emit 'iload (variable-register variable))
+                 (convert-representation :char representation)
                  (emit-move-from-stack target representation))
                 ((eq (variable-representation variable) :long)
                  (aver (variable-register variable))
-                 (case representation
-                   (:int
-                    (emit 'lload (variable-register variable))
-                    (emit 'l2i))
-                   (:char
-                    (sys::%format t "compile-var-ref :char case 2~%")
-                    (aver nil))
-                   (:long
-                    (emit 'lload (variable-register variable)))
-                   (:boolean
-                    (emit 'iconst_1))
-                   (t
-                    (emit 'lload (variable-register variable))
-                    (convert-representation :long nil)))
+                 (emit 'lload (variable-register variable))
+                 (convert-representation :long representation)
                  (emit-move-from-stack target representation))
                 ((eq (variable-representation variable) :boolean)
                  (aver (variable-register variable))
                  (aver (or (null representation) (eq representation :boolean)))
                  (emit 'iload (variable-register variable))
-                 (case representation
-                   (:boolean)
-                   (t
-                    (convert-representation :boolean nil)))
+                 (convert-representation :boolean representation)
                  (emit-move-from-stack target representation))
                 ((variable-register variable)
                  (aload (variable-register variable))



From ehuelsmann at common-lisp.net  Fri Jan 30 06:16:57 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 30 Jan 2009 06:16:57 +0000
Subject: [armedbear-cvs] r11604 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LSmgT-0000XY-TD@common-lisp.net>

Author: ehuelsmann
Date: Fri Jan 30 06:16:49 2009
New Revision: 11604

Log:
Smarter type derivation: start *using* the float and double storage types
(in P2-PLUS and P2-MINUS, others to follow).

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Jan 30 06:16:49 2009
@@ -711,6 +711,7 @@
 (defun maybe-generate-type-check (variable)
   (unless (or (zerop *safety*)
               (variable-special-p variable)
+              ;###
               (eq (variable-representation variable) :int))
     (let ((declared-type (variable-declared-type variable)))
       (unless (eq declared-type :none)
@@ -2323,7 +2324,7 @@
         (emit 'putstatic *this-class* g +lisp-simple-string+)
         (setf *static-code* *code*)
         (setf (gethash string ht) g))))
-     
+
 (defknown compile-constant (t t t) t)
 (defun compile-constant (form target representation)
   (unless target
@@ -6260,38 +6261,119 @@
      `(let (, at decls) , at body)
      (reverse args) (reverse typenames))))
 
+
+(defmacro define-int-bounds-derivation (name (low1 high1 low2 high2)
+                                        &body body)
+  "Associates an integer-bounds calculation function with a numeric
+operator `name', assuming 2 integer arguments."
+  `(setf (get ',name 'int-bounds)
+         #'(lambda (,low1 ,high1 ,low2 ,high2)
+             (declare (ignorable ,low1 ,high1 ,low2 ,high2))
+             , at body)))
+
+
+(defun derive-integer-type (op type1 type2)
+  "Derives the composed integer type of operation `op' given integer
+types `type1' and `type2'."
+  (let ((low1 (integer-type-low type1))
+        (high1 (integer-type-high type1))
+        (low2 (integer-type-low type2))
+        (high2 (integer-type-high type2))
+        (op-fn (get op 'int-bounds)))
+    (assert op-fn)
+    (multiple-value-bind
+          (low high non-int-p)
+        (funcall op-fn low1 high1 low2 high2)
+      (if non-int-p
+          non-int-p
+          (%make-integer-type low high)))))
+
+(defvar numeric-op-type-derivation
+  `(((+ - * /)
+     (integer integer ,#'derive-integer-type)
+     (integer single-float single-float)
+     (integer double-float double-float)
+     (single-float integer single-float)
+     (single-float double-float double-float)
+     (double-float integer double-float)
+     (double-float single-float double-float))
+    ((min max)
+     (integer integer ,#'derive-integer-type)
+     (integer single-float single-float)
+     (integer double-float double-float)
+     (single-float double-float double-float)
+     (double-float single-float double-float)))
+  "Table used to derive the return type of a numeric operation,
+based on the types of the arguments.")
+
+(defun derive-type-numeric-op (op &rest types)
+  "Returns the result type of the numeric operation `op' and the types
+of the operation arguments given in `types'."
+  (let ((types-table
+         (cdr (assoc op numeric-op-type-derivation :test #'member))))
+    (assert types-table)
+    (flet ((match (type1 type2)
+             (do* ((remaining-types types-table (cdr remaining-types)))
+                  ((endp remaining-types)
+                   ;; when we don't find a matching type, return T
+                   T)
+               (destructuring-bind
+                     (t1 t2 result-type)
+                   (car remaining-types)
+                 (when (and (or (subtypep type1 t1)
+                                (compiler-subtypep type1 t1))
+                            (or (subtypep type2 t2)
+                                (compiler-subtypep type2 t2)))
+                   (return-from match
+                     (if (functionp result-type)
+                         (funcall result-type op type1 type2)
+                         result-type)))))))
+      (let ((type1 (car types))
+            (type2 (cadr types)))
+        (when (and (eq type1 type2)
+                   (memq type1 '(SINGLE-FLOAT DOUBLE-FLOAT)))
+          (return-from derive-type-numeric-op type1))
+        (match type1 type2)))))
+
+(defvar zero-integer-type (%make-integer-type 0 0)
+  "Integer type representing the 0 (zero)
+value for use with derive-type-minus.")
+
+(define-int-bounds-derivation - (low1 high1 low2 high2)
+    (values (and low1 low2 (- low1 low2))
+            (and high1 high2 (- high1 high2))))
+
 (defknown derive-type-minus (t) t)
 (defun derive-type-minus (form)
   (let ((args (cdr form))
         (result-type t))
     (case (length args)
       (1
-       (when-args-integer 
-	((%car args))
-	(type1 low1 high1)
-	((low (and high1 (- high1)))
-	 (high (and low1 (- low1))))
-	(setf result-type (%make-integer-type low high))))
+       (setf result-type
+             (derive-type-numeric-op (car form)
+                                     zero-integer-type
+                                     (derive-compiler-type (%car args)))))
       (2
-       (when-args-integer 
-	((%car args) (%cadr args))
-	(type1 low1 high1 type2 low2 high2)
-	((low (and low1 high2 (- low1 high2)))
-	 (high (and high1 low2 (- high1 low2))))
-	(setf result-type (%make-integer-type low high)))))
+       (setf result-type
+             (derive-type-numeric-op (car form)
+                                     (derive-compiler-type (car args))
+                                     (derive-compiler-type (cadr args))))))
     result-type))
 
+
+(define-int-bounds-derivation + (low1 high1 low2 high2)
+    (values (and low1 low2 (+ low1 low2))
+            (and high1 high2 (+ high1 high2))))
+
 (defknown derive-type-plus (t) t)
 (defun derive-type-plus (form)
   (let ((args (cdr form))
         (result-type t))
     (when (= (length args) 2)
-      (when-args-integer 
-       ((%car args) (%cadr args))
-       (type1 low1 high1 type2 low2 high2)
-       ((low (and low1 low2 (+ low1 low2)))
-	(high (and high1 high2 (+ high1 high2))))
-       (setf result-type (%make-integer-type low high))))
+      (setf result-type
+            (derive-type-numeric-op (car form)
+                                    (derive-compiler-type (car args))
+                                    (derive-compiler-type (cadr args)))))
     result-type))
 
 (defun derive-type-times (form)
@@ -6858,9 +6940,9 @@
                         arg1 'stack result-rep
                         arg2 'stack result-rep)
               (emit (case result-rep
-                      (:int 'iadd)
-                      (:long 'ladd)
-                      (:float 'fadd)
+                      (:int    'iadd)
+                      (:long   'ladd)
+                      (:float  'fadd)
                       (:double 'dadd)
                       (t
                        (sys::format
@@ -6937,9 +7019,9 @@
                         arg1 'stack result-rep
                         arg2 'stack result-rep)
               (emit (case result-rep
-                      (:int 'isub)
-                      (:long 'lsub)
-                      (:float 'fsub)
+                      (:int    'isub)
+                      (:long   'lsub)
+                      (:float  'fsub)
                       (:double 'dsub)
                       (t
                        (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%"



From mevenson at common-lisp.net  Fri Jan 30 15:41:00 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Fri, 30 Jan 2009 15:41:00 +0000
Subject: [armedbear-cvs] r11605 - in trunk/abcl: . src/org/armedbear/lisp
	test/lisp/abcl
Message-ID: <E1LSvUK-00029M-DP@common-lisp.net>

Author: mevenson
Date: Fri Jan 30 15:40:57 2009
New Revision: 11605

Log:
ABCL included Lisp tests now working from ASDF and Ant.

The following targets now work from Ant:

    'test.ansi.compiled'
    'test.ansi.intepreted'
    'test.abcl.lisp'

invoking the GCL ANSI tests compiled, GCL ANSI tests interpreted, and the internal ABCL tests.

Packaged the internal ANSI Lisp test use of REGRESSION-TEST as
ABCL-REGRESSION-TEST (nickname abcl-rt) to avoid conflicting with
other test suites that use this.



Modified:
   trunk/abcl/abcl.asd
   trunk/abcl/build.xml
   trunk/abcl/src/org/armedbear/lisp/Version.java
   trunk/abcl/test/lisp/abcl/java-tests.lisp

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Fri Jan 30 15:40:57 2009
@@ -47,7 +47,10 @@
 	   :compile-tests t))
 
 (defsystem :abcl-test-lisp :version "1.0" :components
-	   ((:module package  :pathname "test/lisp/abcl/" :components
+	   ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components
+		     ((:file "rt-package") (:file "rt")))
+	    (:module package  :depends (abcl-rt)
+		     :pathname "test/lisp/abcl/" :components
 		     ((:file "package")))))
 (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp))))
    "Invoke tests with:  (asdf:oos 'asdf:test-op :abcl-tests :force t)."

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Fri Jan 30 15:40:57 2009
@@ -37,7 +37,7 @@
       <echo>Corresponding targets for J have been removed.</echo>
     </target>
 
-    <!-- Checks if JSR-223 support is available - thanks to Mark Everson -->
+    <!-- Checks if JSR-223 support is available - thanks to Mark Evenson -->
     <available property="abcl.jsr-223.p"
 	       classname="javax.script.ScriptEngine"/>
 
@@ -98,6 +98,13 @@
 	<format property="build" pattern="EEE MMM dd yyyy HH:mm:ss zzz"/>
       </tstamp>
 
+      <tstamp>
+	<format property="build.stamp" pattern="yyyymmdd-HHmm"/>
+      </tstamp>
+
+      <property name="abcl.test.log.file"
+		value="abcl-test-${build.stamp}.log"/>
+
       <!--- antversion fails in ant 1.7.1 <antversion property="ant.version" 
 	                                              atleast="1.7"/> -->
       <property name="java.path"
@@ -489,13 +496,12 @@
     </target>
 
     <target name="abcl.test.lisp" 
-	    depends="abcl.test.lisp.asdf"/>
+	    depends="test.ansi.compiled,test.abcl"/>
 
-    <target name="abcl.test.lisp.asdf" 
-	    depends="abcl.jar,abcl.test.ansi.compiled">
-    </target>
 
-    <target name="abcl.test.ansi.interpreted">
+    <target name="test.ansi.interpreted" depends="abcl.jar">
+      <echo>Recording test output in ${abcl.test.log.file}.</echo>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="start" append="yes"/>
       <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
@@ -503,14 +509,13 @@
 	<arg value="--load"/>
 	<arg line="${basedir}/test/lisp/ansi/ansi-tests-interpreted.lisp"/>
       </java>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="stop"/>
+      <echo>Finished recording test output in ${abcl.test.log.file}.</echo>
     </target>
 
-    <property name="abcl.test.log.file"
-	      value="abcl.test.ansi.compiled.${version.src}"/>
-
-    <target name="abcl.test.ansi.compiled">
+    <target name="test.ansi.compiled" depends="abcl.jar">
       <echo>Recording test output in ${abcl.test.log.file}.</echo>
-      <record name="${abcl.test.log.file}" emacsmode="true" action="start"/>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="start" append="yes"/>
       <java fork="true" dir="${basedir}"
 	    classpathref="abcl.classpath.dist"
 	    classname="org.armedbear.lisp.Main">
@@ -519,8 +524,21 @@
  	<arg line="${basedir}/test/lisp/ansi/ansi-tests-compiled.lisp "/> 
       </java>
       <record name="${abcl.test.log.file}" emacsmode="true" action="stop"/>
-      <echo>Finished ecording test output in ${abcl.test.log.file}.</echo>
+      <echo>Finished recording test output in ${abcl.test.log.file}.</echo>
+    </target>
 
+    <target name="test.abcl" depends="abcl.jar">
+      <echo>Recording test output in ${abcl.test.log.file}.</echo>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="start" append="yes"/>
+      <java fork="true" dir="${basedir}"
+	    classpathref="abcl.classpath.dist"
+	    classname="org.armedbear.lisp.Main">
+	<arg value="--noinit"/> 
+	<arg value="--load"/>
+ 	<arg line="${basedir}/test/lisp/abcl/abcl-test.lisp"/>
+      </java>
+      <record name="${abcl.test.log.file}" emacsmode="true" action="stop"/>
+      <echo>Finished recording test output in ${abcl.test.log.file}.</echo>
     </target>
 
     <import file="netbeans-build.xml" optional="true"/> 

Modified: trunk/abcl/src/org/armedbear/lisp/Version.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Version.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Version.java	Fri Jan 30 15:40:57 2009
@@ -41,6 +41,6 @@
 
   public static String getVersion()
   {
-    return "0.13.0-dev";
+    return "0.12.37";
   }
 }

Modified: trunk/abcl/test/lisp/abcl/java-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/java-tests.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/java-tests.lisp	Fri Jan 30 15:40:57 2009
@@ -19,8 +19,8 @@
 
 (in-package #:abcl.test.lisp)
 
-;#+abcl
-;(use-package '#:java)
+#+abcl
+(use-package '#:java)
 
 #+allegro
 (require :jlinker)



From mevenson at common-lisp.net  Fri Jan 30 15:43:04 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Fri, 30 Jan 2009 15:43:04 +0000
Subject: [armedbear-cvs] r11606 - in trunk/abcl: . test/lisp/abcl
Message-ID: <E1LSvWJ-0002Cz-W5@common-lisp.net>

Author: mevenson
Date: Fri Jan 30 15:43:02 2009
New Revision: 11606

Log:
Include new files missing from previous commit.


Added:
   trunk/abcl/test/lisp/abcl/abcl-test.lisp   (contents, props changed)
   trunk/abcl/test/lisp/abcl/package.lisp   (contents, props changed)
Modified:
   trunk/abcl/   (props changed)
   trunk/abcl/test/lisp/abcl/   (props changed)

Added: trunk/abcl/test/lisp/abcl/abcl-test.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/abcl-test.lisp	Fri Jan 30 15:43:02 2009
@@ -0,0 +1,7 @@
+(require 'asdf)
+(handler-case 
+    (progn
+      (asdf:oos 'asdf:load-op :abcl :force t)
+      (asdf:oos 'asdf:test-op :abcl-test-lisp :force t))
+  (t (e) (warn "Exiting after catching ~A" e)))
+(ext:exit)

Added: trunk/abcl/test/lisp/abcl/package.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/package.lisp	Fri Jan 30 15:43:02 2009
@@ -0,0 +1,33 @@
+(defpackage #:abcl.test.lisp 
+  (:use #:cl #:abcl-rt)
+  (:export #:run))
+(in-package #:abcl.test.lisp)
+
+(defparameter *abcl-lisp-test-pathname* nil)
+
+(eval-when (:load-toplevel)
+  (setf *abcl-lisp-test-pathname* *load-truename*))
+
+(defun run ()
+  (progv 
+      '(*default-pathname-defaults*)
+      `(,(merge-pathnames *abcl-lisp-test-pathname* *default-pathname-defaults*))
+    (rem-all-tests)
+
+    (load "test-utilities.lisp")
+
+    (load "compiler-tests.lisp")
+    (load "condition-tests.lisp")
+    (load "file-system-tests.lisp")
+    (load "java-tests.lisp")
+    (load "math-tests.lisp")
+    (load "misc-tests.lisp")
+
+    (do-tests)))
+
+
+
+   
+
+
+	
\ No newline at end of file



From ehuelsmann at common-lisp.net  Sat Jan 31 08:38:55 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 08:38:55 +0000
Subject: [armedbear-cvs] r11607 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTBNP-0005FI-7c@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 08:38:52 2009
New Revision: 11607

Log:
Implement inline float and double calculations for P2-TIMES.
Cleanup some functions which are now unused.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 08:38:52 2009
@@ -512,6 +512,8 @@
 
 (defun type-representation (the-type)
   "Converts a type specification or compiler type into a representation."
+  (when (null the-type)
+    (return-from type-representation))
   (do* ((types type-representations (cdr types)))
        ((endp types) nil)
     (do* ((type-list (cdr (car types)) (cdr type-list))
@@ -1071,6 +1073,8 @@
                  103 ; dsub
                  104 ; imul
                  105 ; lmul
+                 106 ; fmul
+                 107 ; dmul
                  116 ; ineg
                  117 ; lneg
                  118 ; fneg
@@ -1087,6 +1091,7 @@
                  131 ; lxor
                  133 ; i2l
                  134 ; i2f
+                 135 ; i2d
                  136 ; l2i
                  148 ; lcmp
                  153 ; ifeq
@@ -6289,7 +6294,7 @@
           (%make-integer-type low high)))))
 
 (defvar numeric-op-type-derivation
-  `(((+ - * /)
+  `(((+ - *)
      (integer integer ,#'derive-integer-type)
      (integer single-float single-float)
      (integer double-float double-float)
@@ -6297,6 +6302,13 @@
      (single-float double-float double-float)
      (double-float integer double-float)
      (double-float single-float double-float))
+    ((/)
+     (integer single-float single-float)
+     (integer double-float double-float)
+     (single-float integer single-float)
+     (single-float double-float double-float)
+     (double-float integer double-float)
+     (double-float single-float double-float))
     ((min max)
      (integer integer ,#'derive-integer-type)
      (integer single-float single-float)
@@ -6376,34 +6388,29 @@
                                     (derive-compiler-type (cadr args)))))
     result-type))
 
+(define-int-bounds-derivation * (low1 high1 low2 high2)
+  (cond ((or (null low1) (null low2))
+         (values nil nil))
+        ((or (null high1) (null high2))
+         (values (if (or (minusp low1) (minusp low2))
+                     (- (* (abs low1) (abs low2)))
+                     (* low1 low2))
+                 nil))
+        ((or (minusp low1) (minusp low2))
+         (let ((max (* (max (abs low1) (abs high1))
+                       (max (abs low2) (abs high2)))))
+           (values (- max) max)))
+        (t
+         (values (* low1 low2) (* high1 high2)))))
+
 (defun derive-type-times (form)
   (let ((args (cdr form))
         (result-type t))
     (when (= (length args) 2)
-      (let ((arg1 (%car args))
-            (arg2 (%cadr args)))
-        (when (and (integerp arg1) (integerp arg2))
-          (let ((n (* arg1 arg2)))
-            (return-from derive-type-times (%make-integer-type n n))))
-	(when-args-integer 
-	 (arg1 arg2)
-	 (type1 low1 high1 type2 low2 high2)
-	 ((low nil)
-		(high nil))
-	 (cond ((not (and low1 low2))
-		;; Nothing to do.
-		)
-	       ((or (minusp low1) (minusp low2))
-		(when (and high1 high2)
-		  (let ((max (* (max (abs low1) (abs high1))
-				(max (abs low2) (abs high2)))))
-		    (setf low (- max)
-			  high max))))
-	       (t
-		(setf low (* low1 low2))
-		(when (and high1 high2)
-		  (setf high (* high1 high2)))))
-	 (setf result-type (%make-integer-type low high)))))
+      (setf result-type
+            (derive-type-numeric-op (car form)
+                                    (derive-compiler-type (car args))
+                                    (derive-compiler-type (cadr args)))))
   result-type))
 
 (declaim (ftype (function (t) t) derive-type-max))
@@ -6764,56 +6771,36 @@
     (fix-boxing representation nil) ; FIXME use derived result type
     (emit-move-from-stack target representation)))
 
-(defun two-long-ints-times/plus/minus (arg1 arg2 instruction representation)
-  (compile-form arg1 'stack :int)
-  (emit 'i2l)
-  (compile-form arg2 'stack :int)
-  (emit 'i2l)
-  (maybe-emit-clear-values arg1 arg2)
-  (emit instruction)
-  (convert-representation :long representation))
-
 (defun p2-times (form target representation)
   (case (length form)
     (3
      (let* ((args (cdr form))
             (arg1 (%car args))
             (arg2 (%cadr args))
-            type1 type2 result-type value)
+            result-type result-rep value)
        (when (fixnump arg1)
          (rotatef arg1 arg2))
-       (setf type1 (make-integer-type (derive-type arg1))
-             type2 (make-integer-type (derive-type arg2))
-             result-type (make-integer-type (derive-type form)))
+       (setf result-type (derive-compiler-type form)
+             result-rep (type-representation result-type))
        (cond ((and (numberp arg1) (numberp arg2))
               (dformat t "p2-times case 1~%")
               (compile-constant (* arg1 arg2) target representation))
              ((setf value (fixnum-constant-value result-type))
               (dformat t "p2-times case 1a~%")
               (compile-constant value target representation))
-             ((and (fixnum-type-p type1)
-                   (fixnum-type-p type2))
-              (cond ((fixnum-type-p result-type)
-                     (unless (eq representation :int)
-		       (new-fixnum))
-		     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-								arg2 'stack :int)
-                     (emit 'imul)
-                     (unless (eq representation :int)
-                       (emit-invokespecial-init +lisp-fixnum-class+ '("I"))
-                       (fix-boxing representation 'fixnum)))
+             (result-rep
+              (compile-forms-and-maybe-emit-clear-values
+                          arg1 'stack result-rep
+                          arg2 'stack result-rep)
+              (emit (case result-rep
+                      (:int    'imul)
+                      (:long   'lmul)
+                      (:float  'fmul)
+                      (:double 'dmul)
                       (t
-		     (two-long-ints-times/plus/minus 
-		      arg1 arg2 'lmul representation)))
+                       (sys::format t "p2-times: unsupported rep case"))))
+              (convert-representation result-rep representation)
 	      (emit-move-from-stack target representation))
-             ((and (java-long-type-p type1)
-                   (java-long-type-p type2)
-                   (java-long-type-p result-type))
-	      (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
-							 arg2 'stack :long)
-              (emit 'lmul)
-              (convert-representation :long representation)
-              (emit-move-from-stack target representation))
              ((fixnump arg2)
 ;;               (format t "p2-times case 3~%")
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
@@ -6893,20 +6880,6 @@
          (t
           (compile-function-call form target representation))))
 
-(defun fixnum-result-plus/minus (target representation result-type arg1 arg2
-				 int-op long-op)
-  (cond ((or (eq representation :int)
-	     (fixnum-type-p result-type))
-	 (new-fixnum (null representation))
-	 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-						    arg2 'stack :int)
-	 (emit int-op)
-	 (emit-fixnum-init representation))
-	(t
-	 (two-long-ints-times/plus/minus 
-	  arg1 arg2 long-op representation)))
-  (emit-move-from-stack target representation))
-
 (defun p2-plus (form target representation)
   (case (length form)
     (3



From ehuelsmann at common-lisp.net  Sat Jan 31 14:01:01 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 14:01:01 +0000
Subject: [armedbear-cvs] r11608 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTGP7-0001Yv-MG@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 14:00:58 2009
New Revision: 11608

Log:
Support inline comparisons for many types of compiler types (including single and double floats).

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/opcodes.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 14:00:58 2009
@@ -577,6 +577,29 @@
             (emit 'iconst_1))
           (emit op)))))
 
+(defvar common-representations '((:int :long :long)
+                                 (:int :float :double)
+                                 (:int :double :double)
+                                 (:float :int :double)
+                                 (:float :double :double)
+                                 (:double :int :double)
+                                 (:double :float :double))
+  "Representations to convert unequal representations to, in order
+to get the correct (exact where required) comparisons.")
+
+(defun common-representation (rep1 rep2)
+  (when (eq rep1 rep2)
+    (return-from common-representation rep1))
+  (do* ((remaining common-representations (cdr remaining))
+        (rep (car remaining) (car remaining)))
+       ((endp remaining))
+    (destructuring-bind
+          (r1 r2 result) rep
+      (when (and (eq rep1 r1) (eq rep2 r2))
+        (return-from common-representation result)))))
+
+
+
 (declaim (ftype (function t string) pretty-java-class))
 (defun pretty-java-class (class)
   (cond ((equal class +lisp-object-class+)
@@ -1094,6 +1117,10 @@
                  135 ; i2d
                  136 ; l2i
                  148 ; lcmp
+                 149 ; fcmpd
+                 150 ; fcmpg
+                 151 ; dcmpd
+                 152 ; dcmpg
                  153 ; ifeq
                  154 ; ifne
                  155 ; ifge
@@ -3185,6 +3212,21 @@
       (restore-variables saved-vars)))
   t)
 
+
+;;                            <        <=         >        >=         =
+(defvar comparison-ops '(< <= > >= =))
+(defvar comparison-ins
+  '((:int  . #(if_icmpge if_icmpgt if_icmple if_icmplt if_icmpne))
+    (:long . #((lcmp ifge) (lcmp ifgt) (lcmp ifle)
+               (lcmp iflt) (lcmp ifne)))
+    (:float . #((fcmpg ifge) (fcmpg ifgt) (fcmpl ifle)
+                (fcmpl iflt) (fcmpl ifne)))
+    (:double . #((dcmpg ifge) (dcmpg ifgt) (dcmpl ifle)
+                 (dcmpl iflt) (dcmpl ifne))))
+  "Instructions to be generated upon each comparison operation,
+given a specific common representation.")
+
+
 ;; Note that /= is not transitive, so we don't handle it here.
 (defknown p2-numeric-comparison (t t t) t)
 (defun p2-numeric-comparison (form target representation)
@@ -3196,7 +3238,9 @@
        (let* ((arg1 (%car args))
               (arg2 (%cadr args))
               (type1 (derive-compiler-type arg1))
-              (type2 (derive-compiler-type arg2)))
+              (type2 (derive-compiler-type arg2))
+              (common-rep (common-representation (type-representation type1)
+                                                 (type-representation type2))))
          (cond ((and (integerp arg1) (integerp arg2))
                 (let ((result (funcall op arg1 arg2)))
                   (if result
@@ -3204,40 +3248,20 @@
                       (emit-push-false representation)))
                 (emit-move-from-stack target representation)
                 (return-from p2-numeric-comparison))
-               ((and (fixnum-type-p type1)
-                     (fixnum-type-p type2))
-                (let ((LABEL1 (gensym))
-                      (LABEL2 (gensym)))
-		  (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-							     arg2 'stack :int)
-                  (emit (case op
-                          (<  'if_icmpge)
-                          (<= 'if_icmpgt)
-                          (>  'if_icmple)
-                          (>= 'if_icmplt)
-                          (=  'if_icmpne))
-                        LABEL1)
-                  (emit-push-true representation)
-                  (emit 'goto LABEL2)
-                  (label LABEL1)
-                  (emit-push-false representation)
-                  (label LABEL2))
-                (emit-move-from-stack target representation)
-                (return-from p2-numeric-comparison))
-               ((and (java-long-type-p type1)
-                     (java-long-type-p type2))
+               (common-rep
                 (let ((LABEL1 (gensym))
                       (LABEL2 (gensym)))
-		  (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
-							     arg2 'stack :long)
-                  (emit 'lcmp)
-                  (emit (case op
-                          (<  'ifge)
-                          (<= 'ifgt)
-                          (>  'ifle)
-                          (>= 'iflt)
-                          (=  'ifne))
-                        LABEL1)
+		  (compile-forms-and-maybe-emit-clear-values
+                          arg1 'stack common-rep
+                          arg2 'stack common-rep)
+                  (let* ((pos (position op comparison-ops))
+                         (ops-table (cdr (assoc common-rep comparison-ins)))
+                         (ops (aref ops-table pos)))
+                    (if (listp ops)
+                        (progn
+                          (emit (car ops))
+                          (emit (cadr ops) LABEL1))
+                        (emit ops LABEL1)))
                   (emit-push-true representation)
                   (emit 'goto LABEL2)
                   (label LABEL1)

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Sat Jan 31 14:00:58 2009
@@ -201,10 +201,10 @@
 (define-opcode i2c 146 1 nil)
 (define-opcode i2s 147 1 nil)
 (define-opcode lcmp 148 1 -3)
-(define-opcode fcmpl 149 1 nil)
-(define-opcode fcmpg 150 1 nil)
-(define-opcode dcmpl 151 1 nil)
-(define-opcode dcmpg 152 1 nil)
+(define-opcode fcmpl 149 1 -1)
+(define-opcode fcmpg 150 1 -1)
+(define-opcode dcmpl 151 1 -2)
+(define-opcode dcmpg 152 1 -2)
 (define-opcode ifeq 153 3 -1)
 (define-opcode ifne 154 3 -1)
 (define-opcode iflt 155 3 -1)



From ehuelsmann at common-lisp.net  Sat Jan 31 16:39:49 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 16:39:49 +0000
Subject: [armedbear-cvs] r11609 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTIsn-0007RY-2n@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 16:39:48 2009
New Revision: 11609

Log:
Don't enumerate representation conversion inline: we have a generic routine for it now.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 16:39:48 2009
@@ -2722,17 +2722,7 @@
 
 (defun emit-ifne-for-eql (representation instruction-type)
   (emit-invokevirtual +lisp-object-class+ "eql" instruction-type "Z")
-  (case representation
-    (:boolean)
-    (t
-     (let ((label1 (gensym))
-	   (label2 (gensym)))
-       (emit 'ifne label1)
-       (emit-push-nil)
-       (emit 'goto label2)
-       (label label1)
-       (emit-push-t)
-       (label label2)))))
+  (convert-representation :boolean representation))
 
 (defknown p2-eql (t t t) t)
 (define-inlined-function p2-eql (form target representation)
@@ -3282,17 +3272,7 @@
                                     '("I")
                                     "Z")
                 ;; Java boolean on stack here
-                (case representation
-                  (:boolean)
-                  (t
-                   (let ((LABEL1 (gensym))
-                         (LABEL2 (gensym)))
-                     (emit 'ifeq LABEL1)
-                     (emit-push-t)
-                     (emit 'goto LABEL2)
-                     (label LABEL1)
-                     (emit-push-nil)
-                     (label LABEL2))))
+                (convert-representation :boolean representation)
                 (emit-move-from-stack target representation)
                 (return-from p2-numeric-comparison)))))
       (3
@@ -4679,18 +4659,8 @@
           (t
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
            (emit 'instanceof java-class)
-           (case representation
-             (:boolean)
-             (t
-              (let ((LABEL1 (gensym))
-                    (LABEL2 (gensym)))
-                (emit 'ifeq LABEL1)
-                (emit-push-t)
-                (emit 'goto LABEL2)
-                (label LABEL1)
-                (emit-push-nil)
-                (label LABEL2)
-                (emit-move-from-stack target representation))))))))
+           (convert-representation :boolean representation)
+           (emit-move-from-stack target representation)))))
 
 (defun p2-bit-vector-p (form target representation)
   (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector-class+))
@@ -5419,12 +5389,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							   arg2 'stack :long)
                 (emit 'land)
-                (case representation
-                  (:int
-                   (emit 'l2i))
-                  (:long)
-                  (t
-                   (convert-representation :long nil)))
+                (convert-representation :long representation)
                 (emit-move-from-stack target representation))
                ((or (and (java-long-type-p type1)
                          (compiler-subtypep type1 'unsigned-byte))
@@ -5434,12 +5399,7 @@
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack :long
 							   arg2 'stack :long)
                 (emit 'land)
-                (case representation
-                  (:int
-                   (emit 'l2i))
-                  (:long)
-                  (t
-                   (convert-representation :long nil)))
+                (convert-representation :long representation)
                 (emit-move-from-stack target representation))
                ((fixnum-type-p type2)
                 ;;                     (format t "p2-logand LispObject.LOGAND(int) 1~%")



From ehuelsmann at common-lisp.net  Sat Jan 31 16:41:59 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 16:41:59 +0000
Subject: [armedbear-cvs] r11610 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTIus-00081y-V8@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 16:41:58 2009
New Revision: 11610

Log:
Add 2 used - but not enabled - opcodes.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/opcodes.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 16:41:58 2009
@@ -1116,6 +1116,8 @@
                  134 ; i2f
                  135 ; i2d
                  136 ; l2i
+                 141 ; f2d
+                 144 ; d2f
                  148 ; lcmp
                  149 ; fcmpd
                  150 ; fcmpg

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Sat Jan 31 16:41:58 2009
@@ -196,7 +196,7 @@
 (define-opcode f2d 141 1 1)
 (define-opcode d2i 142 1 nil)
 (define-opcode d2l 143 1 nil)
-(define-opcode d2f 144 1 nil)
+(define-opcode d2f 144 1 -1)
 (define-opcode i2b 145 1 nil)
 (define-opcode i2c 146 1 nil)
 (define-opcode i2s 147 1 nil)



From ehuelsmann at common-lisp.net  Sat Jan 31 20:28:11 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 20:28:11 +0000
Subject: [armedbear-cvs] r11611 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTMRn-0008EU-83@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 20:28:09 2009
New Revision: 11611

Log:
Clean up COMPILE-CONSTANT: there's no reason to cast from one type to another at runtime if you can do it compile time.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 20:28:09 2009
@@ -2366,40 +2366,26 @@
   (case representation
     (:int
      (cond ((fixnump form)
-            (emit-push-constant-int form)
-            (emit-move-from-stack target representation)
-            (return-from compile-constant))
+            (emit-push-constant-int form))
            ((integerp form)
             (emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+)
-            (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")
-            (emit-move-from-stack target representation)
-            (return-from compile-constant))
+            (emit-invokevirtual +lisp-object-class+ "intValue" nil "I"))
            (t
             (sys::%format t "compile-constant int representation~%")
-            (assert nil))))
+            (assert nil)))
+     (emit-move-from-stack target representation)
+     (return-from compile-constant))
     (:long
-     (cond ((fixnump form)
-            (case form
-              (0
-               (emit 'lconst_0))
-              (1
-               (emit 'lconst_1))
-              (t
-               (emit-push-constant-int form)
-               (emit 'i2l)))
-            (emit-move-from-stack target representation)
-            (return-from compile-constant))
-           ((<= most-negative-java-long form most-positive-java-long)
-            (emit 'ldc2_w (pool-long form))
-            (return-from compile-constant))
+     (cond ((<= most-negative-java-long form most-positive-java-long)
+            (emit-push-constant-long form))
            ((integerp form)
             (emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+)
-            (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")
-            (emit-move-from-stack target representation)
-            (return-from compile-constant))
+            (emit-invokevirtual +lisp-object-class+ "longValue" nil "J"))
            (t
             (sys::%format t "compile-constant long representation~%")
-            (assert nil))))
+            (assert nil)))
+     (emit-move-from-stack target representation)
+     (return-from compile-constant))
     (:char
      (cond ((characterp form)
             (emit-push-constant-int (char-code form))
@@ -2413,17 +2399,8 @@
      (emit-move-from-stack target representation)
      (return-from compile-constant))
     (:float
-     (cond ((fixnump form)
-            (compile-constant form 'stack :int)
-            (emit 'i2f))
-           ((and (integerp form)
-                 (<= most-negative-java-long form most-positive-java-long))
-            (compile-constant form 'stack :long)
-            (emit 'l2f))
-           ((integerp form)
-            (emit 'getfield *this-class* (declare-bignum form)
-                  +lisp-bignum+)
-            (emit-invokevirtual +lisp-bignum-class+ "floatValue" nil "F"))
+     (cond ((integerp form)
+            (emit-push-constant-float (coerce form 'single-float)))
            ((typep form 'single-float)
             (emit-push-constant-float form))
            ((typep form 'double-float)
@@ -2435,20 +2412,9 @@
      (emit-move-from-stack target representation)
      (return-from compile-constant))
     (:double
-     (cond ((fixnump form)
-            (compile-constant form 'stack :int)
-            (emit 'i2d))
-           ((and (integerp form)
-                 (<= most-negative-java-long form most-positive-java-long))
-            (compile-constant form 'stack :long)
-            (emit 'l2d))
-           ((integerp form)
-            (emit 'getfield *this-class* (declare-bignum form)
-                  +lisp-bignum+)
-            (emit-invokevirtual +lisp-bignum-class+ "doubleValue" nil "D"))
-           ((typep form 'single-float)
-            (emit-push-constant-float form)
-            (emit 'f2d))
+     (cond ((or (integerp form)
+                (typep form 'single-float))
+            (emit-push-constant-double (coerce form 'double-float)))
            ((typep form 'double-float)
             (emit-push-constant-double form))
            (t
@@ -6928,12 +6894,10 @@
               (emit-move-from-stack target representation))
              (t
               (compile-binary-operation "add" args target representation)))))
-    (4
-     ;; (+ a b c) => (+ (+ a b) c)
-     (let ((new-form `(+ (+ ,(second form) ,(third form)) ,(fourth form))))
-       (p2-plus new-form target representation)))
     (t
-     (compile-function-call form target representation))))
+     ;; (+ a b c) => (+ (+ a b) c)
+     (let ((new-form `(+ (+ ,(second form) ,(third form)) ,@(nthcdr 3 form))))
+       (p2-plus new-form target representation)))))
 
 (defun p2-minus (form target representation)
   (case (length form)



From ehuelsmann at common-lisp.net  Sat Jan 31 21:14:25 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 21:14:25 +0000
Subject: [armedbear-cvs] r11612 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTNAX-0001To-33@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 21:14:24 2009
New Revision: 11612

Log:
Count linenumbers correctly again (they were double counted before this commit).

Modified:
   trunk/abcl/src/org/armedbear/lisp/Stream.java

Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Stream.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Stream.java	Sat Jan 31 21:14:24 2009
@@ -1806,6 +1806,8 @@
                 _unreadChar(n);
                 return '\r';
             }
+            else
+              return '\n';
         }
 
         if (n == eolChar) {



From ehuelsmann at common-lisp.net  Sat Jan 31 22:10:34 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 22:10:34 +0000
Subject: [armedbear-cvs] r11613 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTO2s-0003qF-Ua@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 22:10:33 2009
New Revision: 11613

Log:
Fix #'+ compilation with FEWER than 2 arguments.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 22:10:33 2009
@@ -6834,6 +6834,10 @@
 
 (defun p2-plus (form target representation)
   (case (length form)
+    (1
+     (compile-constant 0 target representation))
+    (2
+     (compile-form (cadr form) target representation))
     (3
      (let* ((args (%cdr form))
             (arg1 (%car args))



From ehuelsmann at common-lisp.net  Sat Jan 31 22:43:41 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Jan 2009 22:43:41 +0000
Subject: [armedbear-cvs] r11614 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LTOYv-0005TG-5q@common-lisp.net>

Author: ehuelsmann
Date: Sat Jan 31 22:43:40 2009
New Revision: 11614

Log:
Inline all compiled subtractions instead of only the 2 and 3 argument cases.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 31 22:43:40 2009
@@ -6905,6 +6905,9 @@
 
 (defun p2-minus (form target representation)
   (case (length form)
+    (1
+     ;; generates "Insufficient arguments" error
+     (compile-function-call form target representation))
     (2
      (let* ((arg (%cadr form))
             (type (derive-compiler-type form))
@@ -6967,12 +6970,9 @@
               (emit-move-from-stack target representation))
              (t
               (compile-binary-operation "subtract" args target representation)))))
-    (4
-     ;; (- a b c) => (- (- a b) c)
-     (let ((new-form `(- (- ,(second form) ,(third form)) ,(fourth form))))
-       (p2-minus new-form target representation)))
     (t
-     (compile-function-call form target representation))))
+     (let ((new-form `(- (- ,(second form) ,(third form)) ,@(nthcdr 3 form))))
+       (p2-minus new-form target representation)))))
 
 ;; char/schar string index => character
 (defknown p2-char/schar (t t t) t)



From mevenson at common-lisp.net  Sun Jan  4 11:54:55 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 04 Jan 2009 11:54:55 -0000
Subject: [armedbear-cvs] r11536 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1LJRZG-0007x1-Sb@common-lisp.net>

Author: mevenson
Date: Sun Jan  4 11:54:54 2009
New Revision: 11536

Log:
Finished adding @Override annotations for Primitives.java.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Primitives.java

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Sun Jan  4 11:54:54 2009
@@ -1252,6 +1252,7 @@
       {
         return first.isNotEqualTo(second) ? T : NIL;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1264,6 +1265,7 @@
           return NIL;
         return T;
       }
+      @Override
       public LispObject execute(LispObject[] array) throws ConditionThrowable
       {
         final int length = array.length;
@@ -1285,19 +1287,23 @@
   private static final Primitive LT =
     new Primitive(Symbol.LT, "&rest numbers")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg)
       {
         return T;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return first.isLessThan(second) ? T : NIL;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1307,6 +1313,7 @@
         else
           return NIL;
       }
+      @Override
       public LispObject execute(LispObject[] array) throws ConditionThrowable
       {
         final int length = array.length;
@@ -1323,19 +1330,23 @@
   private static final Primitive LE =
     new Primitive(Symbol.LE, "&rest numbers")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg)
       {
         return T;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return first.isLessThanOrEqualTo(second) ? T : NIL;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1345,6 +1356,7 @@
         else
           return NIL;
       }
+      @Override
       public LispObject execute(LispObject[] array) throws ConditionThrowable
       {
         final int length = array.length;
@@ -1361,19 +1373,23 @@
   private static final Primitive GT =
     new Primitive(Symbol.GT, "&rest numbers")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg)
       {
         return T;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return first.isGreaterThan(second) ? T : NIL;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1383,6 +1399,7 @@
         else
           return NIL;
       }
+      @Override
       public LispObject execute(LispObject[] array) throws ConditionThrowable
       {
         final int length = array.length;
@@ -1399,19 +1416,23 @@
   private static final Primitive GE =
     new Primitive(Symbol.GE, "&rest numbers")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg)
       {
         return T;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return first.isGreaterThanOrEqualTo(second) ? T : NIL;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1421,6 +1442,7 @@
         else
           return NIL;
       }
+      @Override
       public LispObject execute(LispObject[] array) throws ConditionThrowable
       {
         final int length = array.length;
@@ -1436,6 +1458,7 @@
   // ### nth n list => object
   private static final Primitive NTH = new Primitive(Symbol.NTH, "n list")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -1447,6 +1470,7 @@
   private static final Primitive _SET_NTH =
     new Primitive("%set-nth", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1477,6 +1501,7 @@
   private static final Primitive NTHCDR =
     new Primitive(Symbol.NTHCDR, "n list")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -1506,6 +1531,7 @@
   private static final Primitive ERROR =
     new Primitive(Symbol.ERROR, "datum &rest arguments")
     {
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         Error e = new Error();
@@ -1526,6 +1552,7 @@
   private static final Primitive SIGNAL =
     new Primitive(Symbol.SIGNAL, "datum &rest arguments")
     {
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         if (args.length < 1)
@@ -1541,6 +1568,7 @@
   private static final Primitive UNDEFINED_FUNCTION_CALLED =
     new Primitive(Symbol.UNDEFINED_FUNCTION_CALLED, "name arguments")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -1553,6 +1581,7 @@
     new Primitive("%format", PACKAGE_SYS, false,
                   "destination control-string &rest args")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1565,6 +1594,7 @@
         String s = _format(_args);
         return outputFormattedString(s, destination);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth)
         throws ConditionThrowable
@@ -1578,6 +1608,7 @@
         String s = _format(_args);
         return outputFormattedString(s, destination);
       }
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         if (args.length < 2)
@@ -1685,6 +1716,7 @@
   private static final Primitive _DEFUN =
     new Primitive("%defun", PACKAGE_SYS, true, "name definition")
     {
+      @Override
       public LispObject execute(LispObject name, LispObject definition)
         throws ConditionThrowable
       {
@@ -1714,6 +1746,7 @@
   private static final Primitive FDEFINITION_BLOCK_NAME =
     new Primitive("fdefinition-block-name", PACKAGE_SYS, true, "function-name")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Symbol)
@@ -1728,6 +1761,7 @@
   private static final Primitive MACRO_FUNCTION =
     new Primitive(Symbol.MACRO_FUNCTION, "symbol &optional environment")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         LispObject obj = arg.getSymbolFunction();
@@ -1751,6 +1785,7 @@
           }
         return NIL;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -1788,6 +1823,7 @@
   private static final SpecialOperator DEFMACRO =
     new SpecialOperator(Symbol.DEFMACRO)
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -1821,6 +1857,7 @@
   private static final Primitive MAKE_MACRO =
     new Primitive("make-macro", PACKAGE_SYS, true, "name expansion-function")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -1832,6 +1869,7 @@
   private static final Primitive MAKE_SYMBOL_MACRO =
       new Primitive("make-symbol-macro", PACKAGE_SYS, true, "expansion")
   {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
           return new SymbolMacro(arg);
@@ -1843,6 +1881,7 @@
   private static final Primitive _DEFPARAMETER =
     new Primitive("%defparameter", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1869,6 +1908,7 @@
   private static final Primitive _DEFVAR =
     new Primitive("%defvar", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final Symbol symbol;
@@ -1883,6 +1923,7 @@
         symbol.setSpecial(true);
         return symbol;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -1904,6 +1945,7 @@
   private static final Primitive _DEFCONSTANT =
     new Primitive("%defconstant", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -1933,6 +1975,7 @@
   private static final SpecialOperator COND =
     new SpecialOperator(Symbol.COND, "&rest clauses")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -1963,6 +2006,7 @@
   private static final SpecialOperator CASE =
     new SpecialOperator(Symbol.CASE, "keyform &body cases")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -2009,6 +2053,7 @@
   private static final SpecialOperator ECASE =
     new SpecialOperator(Symbol.ECASE, "keyform &body cases")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -2075,10 +2120,12 @@
     new Primitive(Symbol.UPGRADED_ARRAY_ELEMENT_TYPE,
                   "typespec &optional environment")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return getUpgradedArrayElementType(arg);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2091,6 +2138,7 @@
   private static final Primitive ARRAY_RANK =
     new Primitive(Symbol.ARRAY_RANK, "array")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -2109,6 +2157,7 @@
   private static final Primitive ARRAY_DIMENSIONS =
     new Primitive(Symbol.ARRAY_DIMENSIONS, "array")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -2126,6 +2175,7 @@
   private static final Primitive ARRAY_DIMENSION =
     new Primitive(Symbol.ARRAY_DIMENSION, "array axis-number")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2155,6 +2205,7 @@
   private static final Primitive ARRAY_TOTAL_SIZE =
     new Primitive(Symbol.ARRAY_TOTAL_SIZE, "array")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -2174,6 +2225,7 @@
   private static final Primitive ARRAY_ELEMENT_TYPE =
     new Primitive(Symbol.ARRAY_ELEMENT_TYPE, "array")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -2191,6 +2243,7 @@
   private static final Primitive ADJUSTABLE_ARRAY_P =
     new Primitive(Symbol.ADJUSTABLE_ARRAY_P, "array")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -2208,6 +2261,7 @@
   private static final Primitive ARRAY_DISPLACEMENT =
     new Primitive(Symbol.ARRAY_DISPLACEMENT, "array")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -2225,6 +2279,7 @@
   private static final Primitive ARRAY_IN_BOUNDS_P =
     new Primitive(Symbol.ARRAY_IN_BOUNDS_P, "array &rest subscripts")
     {
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         if (args.length < 1)
@@ -2271,6 +2326,7 @@
   private static final Primitive _ARRAY_ROW_MAJOR_INDEX =
     new Primitive("%array-row-major-index", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2292,10 +2348,12 @@
   private static final Primitive AREF =
     new Primitive(Symbol.AREF, "array &rest subscripts")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final AbstractArray array;
@@ -2315,11 +2373,13 @@
         sb.append('.');
         return error(new ProgramError(sb.toString()));
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return first.AREF(second);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -2352,6 +2412,7 @@
           }
         return array.get(subs);
       }
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         final AbstractArray array;
@@ -2384,6 +2445,7 @@
     new Primitive("aset", PACKAGE_SYS, true,
                   "array subscripts new-element")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2402,6 +2464,7 @@
         array.aset(0, second);
         return second;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -2409,6 +2472,7 @@
         first.aset(second, third);
         return third;
       }
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         final AbstractArray array;
@@ -2443,6 +2507,7 @@
   private static final Primitive ROW_MAJOR_AREF =
     new Primitive(Symbol.ROW_MAJOR_AREF, "array index")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2464,6 +2529,7 @@
   private static final Primitive VECTOR =
     new Primitive(Symbol.VECTOR, "&rest objects")
     {
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         return new SimpleVector(args);
@@ -2474,6 +2540,7 @@
   private static final Primitive FILL_POINTER =
     new Primitive(Symbol.FILL_POINTER, "vector")
     {
+      @Override
       public LispObject execute(LispObject arg)
         throws ConditionThrowable
       {
@@ -2494,6 +2561,7 @@
   private static final Primitive _SET_FILL_POINTER =
     new Primitive("%set-fill-pointer", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2519,6 +2587,7 @@
   private static final Primitive VECTOR_PUSH =
     new Primitive(Symbol.VECTOR_PUSH, "new-element vector")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2548,12 +2617,14 @@
     new Primitive(Symbol.VECTOR_PUSH_EXTEND,
                   "new-element vector &optional extension")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return second.VECTOR_PUSH_EXTEND(first);
       }
 
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -2566,6 +2637,7 @@
   private static final Primitive VECTOR_POP =
     new Primitive(Symbol.VECTOR_POP, "vector")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final AbstractVector v;
@@ -2593,6 +2665,7 @@
   private static final Primitive TYPE_OF =
     new Primitive(Symbol.TYPE_OF, "object")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.typeOf();
@@ -2603,6 +2676,7 @@
   private static final Primitive CLASS_OF =
     new Primitive(Symbol.CLASS_OF, "object")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.classOf();
@@ -2613,6 +2687,7 @@
   private static final Primitive SIMPLE_TYPEP =
     new Primitive("simple-typep", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -2625,6 +2700,7 @@
   private static final Primitive FUNCTION_LAMBDA_EXPRESSION =
     new Primitive(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final LispObject value1, value2, value3;
@@ -2673,25 +2749,30 @@
   public static final Primitive FUNCALL =
     new Primitive(Symbol.FUNCALL, "function &rest args")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return LispThread.currentThread().execute(arg);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return LispThread.currentThread().execute(first, second);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
       {
         return LispThread.currentThread().execute(first, second, third);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth)
         throws ConditionThrowable
@@ -2699,6 +2780,7 @@
         return LispThread.currentThread().execute(first, second, third,
                                                   fourth);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth,
                                 LispObject fifth)
@@ -2707,6 +2789,7 @@
         return LispThread.currentThread().execute(first, second, third,
                                                   fourth, fifth);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth,
                                 LispObject fifth, LispObject sixth)
@@ -2715,6 +2798,7 @@
         return LispThread.currentThread().execute(first, second, third,
                                                   fourth, fifth, sixth);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth,
                                 LispObject fifth, LispObject sixth,
@@ -2725,6 +2809,7 @@
                                                   fourth, fifth, sixth,
                                                   seventh);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth,
                                 LispObject fifth, LispObject sixth,
@@ -2735,6 +2820,7 @@
                                                   fourth, fifth, sixth,
                                                   seventh, eigth);
       }
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         final int length = args.length - 1; // Number of arguments.
@@ -2759,14 +2845,17 @@
   public static final Primitive APPLY =
     new Primitive(Symbol.APPLY, "function &rest args")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject fun, LispObject args)
         throws ConditionThrowable
       {
@@ -2799,6 +2888,7 @@
             }
           }
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -2818,6 +2908,7 @@
           }
         return type_error(third, Symbol.LIST);
       }
+      @Override
       public LispObject execute(final LispObject[] args) throws ConditionThrowable
       {
         final int numArgs = args.length;
@@ -2844,6 +2935,7 @@
   private static final Primitive MAPCAR =
     new Primitive(Symbol.MAPCAR, "function &rest lists")
     {
+      @Override
       public LispObject execute(LispObject fun, LispObject list)
         throws ConditionThrowable
       {
@@ -2878,6 +2970,7 @@
         thread._values = null;
         return result;
       }
+      @Override
       public LispObject execute(LispObject fun, LispObject list1,
                                 LispObject list2)
         throws ConditionThrowable
@@ -2906,6 +2999,7 @@
         thread._values = null;
         return result;
       }
+      @Override
       public LispObject execute(final LispObject[] args)
         throws ConditionThrowable
       {
@@ -2947,6 +3041,7 @@
   private static final Primitive MAPC =
     new Primitive(Symbol.MAPC, "function &rest lists")
     {
+      @Override
       public LispObject execute(LispObject fun, LispObject list)
         throws ConditionThrowable
       {
@@ -2969,6 +3064,7 @@
         thread._values = null;
         return result;
       }
+      @Override
       public LispObject execute(LispObject fun, LispObject list1,
                                 LispObject list2)
         throws ConditionThrowable
@@ -2984,6 +3080,7 @@
         thread._values = null;
         return result;
       }
+      @Override
       public LispObject execute(final LispObject[] args)
         throws ConditionThrowable
       {
@@ -3022,12 +3119,14 @@
   private static final Primitive MACROEXPAND =
     new Primitive(Symbol.MACROEXPAND, "form &optional env")
     {
+      @Override
       public LispObject execute(LispObject form) throws ConditionThrowable
       {
         return macroexpand(form,
                            new Environment(),
                            LispThread.currentThread());
       }
+      @Override
       public LispObject execute(LispObject form, LispObject env)
         throws ConditionThrowable
       {
@@ -3041,12 +3140,14 @@
   private static final Primitive MACROEXPAND_1 =
     new Primitive(Symbol.MACROEXPAND_1, "form &optional env")
     {
+      @Override
       public LispObject execute(LispObject form) throws ConditionThrowable
       {
         return macroexpand_1(form,
                              new Environment(),
                              LispThread.currentThread());
       }
+      @Override
       public LispObject execute(LispObject form, LispObject env)
         throws ConditionThrowable
       {
@@ -3060,10 +3161,12 @@
   private static final Primitive GENSYM =
     new Primitive(Symbol.GENSYM, "&optional x")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return gensym("G", LispThread.currentThread());
       }
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Fixnum)
@@ -3098,6 +3201,7 @@
   // ### string
   private static final Primitive STRING = new Primitive(Symbol.STRING, "x")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.STRING();
@@ -3111,6 +3215,7 @@
   private static final Primitive INTERN =
     new Primitive(Symbol.INTERN, "string &optional package")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final SimpleString s;
@@ -3122,6 +3227,7 @@
         Package pkg = (Package) Symbol._PACKAGE_.symbolValue(thread);
         return pkg.intern(s, thread);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -3140,6 +3246,7 @@
   private static final Primitive UNINTERN =
     new Primitive(Symbol.UNINTERN, "symbol &optional package")
     {
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         if (args.length == 0 || args.length > 2)
@@ -3158,6 +3265,7 @@
   private static final Primitive FIND_PACKAGE =
     new Primitive(Symbol.FIND_PACKAGE, "name")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Package)
@@ -3189,6 +3297,7 @@
   private static final Primitive _MAKE_PACKAGE =
     new Primitive("%make-package", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -3273,6 +3382,7 @@
   private static final Primitive _IN_PACKAGE =
     new Primitive("%in-package", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final String packageName = javaString(arg);
@@ -3295,6 +3405,7 @@
   private static final Primitive USE_PACKAGE =
     new Primitive(Symbol.USE_PACKAGE, "packages-to-use &optional package")
     {
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         if (args.length < 1 || args.length > 2)
@@ -3323,6 +3434,7 @@
   private static final Primitive PACKAGE_SYMBOLS =
     new Primitive("package-symbols", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return coerceToPackage(arg).getSymbols();
@@ -3333,6 +3445,7 @@
   private static final Primitive PACKAGE_INTERNAL_SYMBOLS =
     new Primitive("package-internal-symbols", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS();
@@ -3343,6 +3456,7 @@
   private static final Primitive PACKAGE_EXTERNAL_SYMBOLS =
     new Primitive("package-external-symbols", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS();
@@ -3353,6 +3467,7 @@
   private static final Primitive PACKAGE_INHERITED_SYMBOLS =
     new Primitive("package-inherited-symbols", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS();
@@ -3363,6 +3478,7 @@
   private static final Primitive EXPORT =
     new Primitive(Symbol.EXPORT, "symbols &optional package")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final Package pkg = (Package) Symbol._PACKAGE_.symbolValue();
@@ -3376,6 +3492,7 @@
         return T;
       }
 
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -3395,11 +3512,13 @@
   private static final Primitive FIND_SYMBOL =
     new Primitive(Symbol.FIND_SYMBOL, "string &optional package")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return getCurrentPackage().findSymbol(arg.getStringValue());
       }
 
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -3412,23 +3531,27 @@
   private static final Primitive FSET =
     new Primitive("fset", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return execute(first, second, NIL, NIL, NIL);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
       {
         return execute(first, second, third, NIL, NIL);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth)
         throws ConditionThrowable
       {
         return execute(first, second, third, fourth, NIL);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth,
                                 LispObject fifth)
@@ -3477,6 +3600,7 @@
   private static final Primitive _SET_SYMBOL_PLIST =
     new Primitive("%set-symbol-plist", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -3489,11 +3613,13 @@
   private static final Primitive GETF =
     new Primitive(Symbol.GETF, "plist indicator &optional default")
     {
+      @Override
       public LispObject execute(LispObject plist, LispObject indicator)
         throws ConditionThrowable
       {
         return getf(plist, indicator, NIL);
       }
+      @Override
       public LispObject execute(LispObject plist, LispObject indicator,
                                 LispObject defaultValue)
         throws ConditionThrowable
@@ -3506,11 +3632,13 @@
   private static final Primitive GET =
     new Primitive(Symbol.GET, "symbol indicator &optional default")
     {
+      @Override
       public LispObject execute(LispObject symbol, LispObject indicator)
         throws ConditionThrowable
       {
         return get(symbol, indicator, NIL);
       }
+      @Override
       public LispObject execute(LispObject symbol, LispObject indicator,
                                 LispObject defaultValue)
         throws ConditionThrowable
@@ -3523,6 +3651,7 @@
   private static final Primitive PUT =
     new Primitive("put", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject symbol, LispObject indicator,
                                 LispObject value)
         throws ConditionThrowable
@@ -3536,6 +3665,7 @@
             return type_error(symbol, Symbol.SYMBOL);
           }
       }
+      @Override
       public LispObject execute(LispObject symbol, LispObject indicator,
                                 LispObject defaultValue, LispObject value)
         throws ConditionThrowable
@@ -3555,6 +3685,7 @@
   private static final SpecialOperator MACROLET =
     new SpecialOperator(Symbol.MACROLET, "definitions &rest body")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3592,6 +3723,7 @@
     new Primitive("make-expander-for-macrolet", PACKAGE_SYS, true,
                   "definition")
     {
+      @Override
       public LispObject execute(LispObject definition)
         throws ConditionThrowable
       {
@@ -3617,6 +3749,7 @@
   private static final SpecialOperator TAGBODY =
     new SpecialOperator(Symbol.TAGBODY, "&rest statements")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3689,6 +3822,7 @@
   private static final SpecialOperator GO =
     new SpecialOperator(Symbol.GO, "tag")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3707,6 +3841,7 @@
   private static final SpecialOperator BLOCK =
     new SpecialOperator(Symbol.BLOCK, "name &rest forms")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3748,6 +3883,7 @@
   private static final SpecialOperator RETURN_FROM =
     new SpecialOperator(Symbol.RETURN_FROM, "name &optional value")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3784,6 +3920,7 @@
   private static final SpecialOperator CATCH =
     new SpecialOperator(Symbol.CATCH, "tag &body body")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3823,6 +3960,7 @@
   private static final SpecialOperator THROW =
     new SpecialOperator(Symbol.THROW, "tag result")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3840,6 +3978,7 @@
   private static final SpecialOperator UNWIND_PROTECT =
     new SpecialOperator(Symbol.UNWIND_PROTECT, "protected &body cleanup")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3872,6 +4011,7 @@
   private static final SpecialOperator EVAL_WHEN =
     new SpecialOperator(Symbol.EVAL_WHEN, "situations &rest forms")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3895,6 +4035,7 @@
     new SpecialOperator(Symbol.MULTIPLE_VALUE_BIND,
                         "vars value-form &body body")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -3998,6 +4139,7 @@
     new SpecialOperator(Symbol.MULTIPLE_VALUE_PROG1,
                         "values-form &rest forms")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -4020,6 +4162,7 @@
   private static final SpecialOperator MULTIPLE_VALUE_CALL =
     new SpecialOperator(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -4071,6 +4214,7 @@
   private static final SpecialOperator AND =
     new SpecialOperator(Symbol.AND, "&rest forms")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -4099,6 +4243,7 @@
   private static final SpecialOperator OR =
     new SpecialOperator(Symbol.OR, "&rest forms")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -4128,6 +4273,7 @@
   private static final SpecialOperator MULTIPLE_VALUE_LIST =
     new SpecialOperator(Symbol.MULTIPLE_VALUE_LIST, "value-form")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -4153,6 +4299,7 @@
   private static final SpecialOperator NTH_VALUE =
     new SpecialOperator(Symbol.NTH_VALUE, "n form")
     {
+      @Override
       public LispObject execute(LispObject args, Environment env)
         throws ConditionThrowable
       {
@@ -4180,6 +4327,7 @@
   private static final Primitive CALL_COUNT =
     new Primitive("call-count", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return new Fixnum(arg.getCallCount());
@@ -4190,6 +4338,7 @@
   private static final Primitive SET_CALL_COUNT =
     new Primitive("set-call-count", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4202,6 +4351,7 @@
   private static final Primitive LAMBDA_NAME =
     new Primitive("lambda-name", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Operator)
@@ -4220,6 +4370,7 @@
   private static final Primitive _SET_LAMBDA_NAME =
     new Primitive("%set-lambda-name", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4244,6 +4395,7 @@
   private static final Primitive SHRINK_VECTOR =
     new Primitive("shrink-vector", PACKAGE_SYS, true, "vector new-size")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4256,6 +4408,7 @@
   private static final Primitive SUBSEQ =
     new Primitive(Symbol.SUBSEQ, "sequence start &optional end")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4284,6 +4437,7 @@
           }
         return type_error(first, Symbol.SEQUENCE);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -4354,23 +4508,28 @@
   private static final Primitive LIST =
     new Primitive(Symbol.LIST, "&rest objects")
     {
+      @Override
       public LispObject execute()
       {
         return NIL;
       }
+      @Override
       public LispObject execute(LispObject arg)
       {
         return new Cons(arg);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
       {
         return new Cons(first, new Cons(second));
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
       {
         return new Cons(first, new Cons(second, new Cons(third)));
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth)
       {
@@ -4379,6 +4538,7 @@
                                  new Cons(third,
                                           new Cons(fourth))));
       }
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         LispObject result = NIL;
@@ -4392,25 +4552,30 @@
   private static final Primitive LIST_STAR =
     new Primitive(Symbol.LIST_STAR, "&rest objects")
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return error(new WrongNumberOfArgumentsException(this));
       }
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg;
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         return new Cons(first, second);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
       {
         return new Cons(first, new Cons(second, third));
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third, LispObject fourth)
         throws ConditionThrowable
@@ -4419,6 +4584,7 @@
                         new Cons(second,
                                  new Cons(third, fourth)));
       }
+      @Override
       public LispObject execute(LispObject[] args) throws ConditionThrowable
       {
         int i = args.length - 1;
@@ -4433,6 +4599,7 @@
   public static final Primitive NREVERSE =
     new Primitive(Symbol.NREVERSE, "sequence")
     {
+      @Override
       public LispObject execute (LispObject arg) throws ConditionThrowable
       {
         return arg.nreverse();
@@ -4443,6 +4610,7 @@
   private static final Primitive NRECONC =
     new Primitive(Symbol.NRECONC, "list tail")
     {
+      @Override
       public LispObject execute(LispObject list, LispObject obj)
         throws ConditionThrowable
       {
@@ -4489,6 +4657,7 @@
   private static final Primitive REVERSE =
     new Primitive(Symbol.REVERSE, "sequence")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.reverse();
@@ -4499,6 +4668,7 @@
   private static final Primitive DELETE_EQ =
     new Primitive("delete-eq", PACKAGE_SYS, true, "item sequence")
     {
+      @Override
       public LispObject execute(LispObject item, LispObject sequence)
         throws ConditionThrowable
       {
@@ -4513,6 +4683,7 @@
   private static final Primitive DELETE_EQL =
     new Primitive("delete-eql", PACKAGE_SYS, true, "item sequence")
     {
+      @Override
       public LispObject execute(LispObject item, LispObject sequence)
         throws ConditionThrowable
       {
@@ -4527,6 +4698,7 @@
   private static final Primitive LIST_DELETE_EQ =
     new Primitive("list-delete-eq", PACKAGE_SYS, true, "item list")
     {
+      @Override
       public LispObject execute(LispObject item, LispObject list)
         throws ConditionThrowable
       {
@@ -4576,6 +4748,7 @@
   private static final Primitive LIST_DELETE_EQL =
     new Primitive("list-delete-eql", PACKAGE_SYS, true, "item list")
     {
+      @Override
       public LispObject execute(LispObject item, LispObject list)
         throws ConditionThrowable
       {
@@ -4625,6 +4798,7 @@
   private static final Primitive VECTOR_DELETE_EQ =
     new Primitive("vector-delete-eq", PACKAGE_SYS, true, "item vector")
     {
+      @Override
       public LispObject execute(LispObject item, LispObject vector)
         throws ConditionThrowable
       {
@@ -4644,6 +4818,7 @@
   private static final Primitive VECTOR_DELETE_EQL =
     new Primitive("vector-delete-eql", PACKAGE_SYS, true, "item vector")
     {
+      @Override
       public LispObject execute(LispObject item, LispObject vector)
         throws ConditionThrowable
       {
@@ -4664,6 +4839,7 @@
   private static final Primitive _SET_ELT =
     new Primitive("%set-elt", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -4701,6 +4877,7 @@
   private static final Primitive _MAKE_LIST =
     new Primitive("%make-list", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4719,6 +4896,7 @@
   private static final Primitive _MEMBER =
     new Primitive("%member", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject item, LispObject list,
                                 LispObject key, LispObject test,
                                 LispObject testNot)
@@ -4794,6 +4972,7 @@
   private static final Primitive FUNCALL_KEY =
     new Primitive("funcall-key", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4807,6 +4986,7 @@
   private static final Primitive COERCE_TO_FUNCTION =
     new Primitive("coerce-to-function", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return coerceToFunction(arg);
@@ -4817,6 +4997,7 @@
   private static final Primitive MAKE_CLOSURE =
     new Primitive("make-closure", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4837,6 +5018,7 @@
   private static final Primitive STREAMP =
     new Primitive(Symbol.STREAMP, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg instanceof Stream ? T : NIL;
@@ -4847,6 +5029,7 @@
   private static final Primitive INTEGERP =
     new Primitive(Symbol.INTEGERP, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg.INTEGERP();
@@ -4857,6 +5040,7 @@
   private static final Primitive EVENP =
     new Primitive(Symbol.EVENP, "integer")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.EVENP();
@@ -4866,6 +5050,7 @@
   // ### oddp
   private static final Primitive ODDP = new Primitive(Symbol.ODDP, "integer")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.ODDP();
@@ -4876,6 +5061,7 @@
   private static final Primitive NUMBERP =
     new Primitive(Symbol.NUMBERP, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg.NUMBERP();
@@ -4886,6 +5072,7 @@
   private static final Primitive REALP =
     new Primitive(Symbol.REALP, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg.REALP();
@@ -4896,6 +5083,7 @@
   private static final Primitive RATIONALP =
     new Primitive(Symbol.RATIONALP,"object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg.RATIONALP();
@@ -4906,6 +5094,7 @@
   private static final Primitive COMPLEX =
     new Primitive(Symbol.COMPLEX, "realpart &optional imagpart")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof SingleFloat)
@@ -4916,6 +5105,7 @@
           return arg;
         return type_error(arg, Symbol.REAL);
       }
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -4927,6 +5117,7 @@
   private static final Primitive COMPLEXP =
     new Primitive(Symbol.COMPLEXP, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg.COMPLEXP();
@@ -4937,6 +5128,7 @@
   private static final Primitive NUMERATOR =
     new Primitive(Symbol.NUMERATOR, "rational")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.NUMERATOR();
@@ -4947,6 +5139,7 @@
   private static final Primitive DENOMINATOR =
     new Primitive(Symbol.DENOMINATOR, "rational")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.DENOMINATOR();
@@ -4957,6 +5150,7 @@
   private static final Primitive REALPART =
     new Primitive(Symbol.REALPART, "number")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Complex)
@@ -4971,6 +5165,7 @@
   private static final Primitive IMAGPART =
     new Primitive(Symbol.IMAGPART, "number")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Complex)
@@ -4983,6 +5178,7 @@
   private static final Primitive INTEGER_LENGTH =
     new Primitive(Symbol.INTEGER_LENGTH, "integer")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Fixnum)
@@ -5008,6 +5204,7 @@
   private static final Primitive GCD_2 =
     new Primitive("gcd-2", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5032,6 +5229,7 @@
   private static final Primitive IDENTITY_HASH_CODE =
     new Primitive("identity-hash-code", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return new Fixnum(System.identityHashCode(arg));
@@ -5043,6 +5241,7 @@
   private static final Primitive SIMPLE_VECTOR_SEARCH =
     new Primitive("simple-vector-search", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5117,6 +5316,7 @@
   private static final Primitive UPTIME =
     new Primitive("uptime", PACKAGE_EXT, true)
     {
+      @Override
       public LispObject execute() throws ConditionThrowable
       {
         return number(System.currentTimeMillis() - Main.startTimeMillis);
@@ -5127,6 +5327,7 @@
   private static final Primitive BUILT_IN_FUNCTION_P =
     new Primitive("built-in-function-p", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5144,6 +5345,7 @@
   private static final Primitive INSPECTED_PARTS =
     new Primitive("inspected-parts", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.getParts();
@@ -5154,6 +5356,7 @@
   private static final Primitive INSPECTED_DESCRIPTION =
     new Primitive("inspected-description", PACKAGE_SYS, false)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         return arg.getDescription();
@@ -5164,6 +5367,7 @@
   public static final Primitive SYMBOL_NAME =
     new Primitive(Symbol.SYMBOL_NAME, "symbol")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5181,6 +5385,7 @@
   public static final Primitive SYMBOL_PACKAGE =
     new Primitive(Symbol.SYMBOL_PACKAGE, "symbol")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5198,6 +5403,7 @@
   public static final Primitive SYMBOL_FUNCTION =
     new Primitive(Symbol.SYMBOL_FUNCTION, "symbol")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5218,6 +5424,7 @@
   public static final Primitive _SET_SYMBOL_FUNCTION =
     new Primitive("%set-symbol-function", PACKAGE_SYS, false, "symbol function")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5237,6 +5444,7 @@
   public static final Primitive SYMBOL_PLIST =
     new Primitive(Symbol.SYMBOL_PLIST, "symbol")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5254,6 +5462,7 @@
   public static final Primitive KEYWORDP =
     new Primitive(Symbol.KEYWORDP, "object")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof Symbol)
@@ -5269,6 +5478,7 @@
   public static final Primitive MAKE_SYMBOL =
     new Primitive(Symbol.MAKE_SYMBOL, "name")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         if (arg instanceof SimpleString)
@@ -5284,6 +5494,7 @@
   public static final Primitive MAKUNBOUND =
     new Primitive(Symbol.MAKUNBOUND, "symbol")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5302,6 +5513,7 @@
   private static final Primitive _CLASS_NAME =
     new Primitive("%class-name", PACKAGE_SYS, true, "class")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5319,6 +5531,7 @@
   private static final Primitive _SET_CLASS_NAME =
     new Primitive("%set-class-name", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5338,6 +5551,7 @@
   private static final Primitive CLASS_LAYOUT =
     new Primitive("class-layout", PACKAGE_SYS, true, "class")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5356,6 +5570,7 @@
   private static final Primitive _SET_CLASS_LAYOUT =
     new Primitive("%set-class-layout", PACKAGE_SYS, true, "class layout")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5380,6 +5595,7 @@
   private static final Primitive CLASS_DIRECT_SUPERCLASSES =
     new Primitive("class-direct-superclasses", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5397,6 +5613,7 @@
   private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES =
     new Primitive("%set-class-direct-superclasses", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5416,6 +5633,7 @@
   private static final Primitive CLASS_DIRECT_SUBCLASSES =
     new Primitive("class-direct-subclasses", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5434,6 +5652,7 @@
     new Primitive("%set-class-direct-subclasses", PACKAGE_SYS, true,
                   "class direct-subclasses")
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5453,6 +5672,7 @@
   private static final Primitive _CLASS_PRECEDENCE_LIST =
     new Primitive("%class-precedence-list", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5470,6 +5690,7 @@
   private static final Primitive SET_CLASS_PRECEDENCE_LIST =
     new Primitive("set-class-precedence-list", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5489,6 +5710,7 @@
   private static final Primitive CLASS_DIRECT_METHODS =
     new Primitive("class-direct-methods", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg)
         throws ConditionThrowable
       {
@@ -5507,6 +5729,7 @@
   private static final Primitive _SET_CLASS_DIRECT_METHODS =
     new Primitive("%set-class-direct-methods", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5526,6 +5749,7 @@
   private static final Primitive CLASS_DOCUMENTATION =
     new Primitive("class-documentation", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg)
         throws ConditionThrowable
       {
@@ -5544,6 +5768,7 @@
   private static final Primitive _SET_CLASS_DOCUMENTATION =
     new Primitive("%set-class-documentation", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5563,6 +5788,7 @@
   private static final Primitive CLASS_FINALIZED_P =
     new Primitive("class-finalized-p", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5580,6 +5806,7 @@
   private static final Primitive _SET_CLASS_FINALIZED_P =
     new Primitive("%set-class-finalized-p", PACKAGE_SYS, true)
     {
+      @Override
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
@@ -5599,6 +5826,7 @@
   private static final Primitive CLASSP =
     new Primitive("classp", PACKAGE_EXT, true)
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg instanceof LispClass ? T : NIL;
@@ -5609,6 +5837,7 @@
   private static final Primitive CHAR_TO_UTF8 =
     new Primitive("char-to-utf8", PACKAGE_EXT, true)
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         final LispCharacter c;
@@ -5649,6 +5878,7 @@
     new Primitive("%documentation", PACKAGE_SYS, true,
                   "object doc-type")
     {
+      @Override
       public LispObject execute(LispObject object, LispObject docType)
         throws ConditionThrowable
       {
@@ -5671,6 +5901,7 @@
     new Primitive("%set-documentation", PACKAGE_SYS, true,
                   "object doc-type documentation")
     {
+      @Override
       public LispObject execute(LispObject object, LispObject docType,
                                 LispObject documentation)
         throws ConditionThrowable
@@ -5685,6 +5916,7 @@
     new Primitive("%putf", PACKAGE_SYS, true,
                   "plist indicator new-value")
     {
+      @Override
       public LispObject execute(LispObject plist, LispObject indicator,
                                 LispObject newValue)
         throws ConditionThrowable
@@ -5697,6 +5929,7 @@
   private static final Primitive FUNCTION_PLIST =
     new Primitive("function-plist", PACKAGE_SYS, true, "function")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5714,6 +5947,7 @@
   private static final Primitive MAKE_KEYWORD =
     new Primitive("make-keyword", PACKAGE_SYS, true, "symbol")
     {
+      @Override
       public LispObject execute(LispObject arg) throws ConditionThrowable
       {
         try
@@ -5731,6 +5965,7 @@
   private static final Primitive STANDARD_OBJECT_P =
     new Primitive("standard-object-p", PACKAGE_SYS, true, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         return arg instanceof StandardObject ? T : NIL;
@@ -5741,6 +5976,7 @@
   private static final Primitive COPY_TREE =
     new Primitive(Symbol.COPY_TREE, "object")
     {
+      @Override
       public LispObject execute(LispObject arg)
       {
         if (arg instanceof Cons)