[armedbear-cvs] r11844 - trunk/abcl/src/org/armedbear/lisp

[Ville Voutilainen]

Author: vvoutilainen
Date: Fri May  8 17:11:15 2009
New Revision: 11844

Log:
More list/list* cleanup, also don't use default nil values for my
recently added &optionals, that's not necessary.


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 May  8 17:11:15 2009
@@ -1001,7 +1001,7 @@
 ;; the value of a constant defined with DEFCONSTANT, calling built-in Lisp
 ;; functions with a wrong number of arguments or malformed keyword argument
 ;; lists, and using unrecognized declaration specifiers." (3.2.5)
-(defun check-number-of-args (form n &optional (minimum nil))
+(defun check-number-of-args (form n &optional minimum)
   (declare (type fixnum n))
   (let* ((op (car form))
          (args (cdr form))
@@ -6505,68 +6505,45 @@
        (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+)))
     (emit-move-from-stack target representation)))
 
+(defun cons-for-list/list* (args target representation &optional list-star-p)
+  (let ((cons-heads (if list-star-p
+			(butlast args 1)
+		      args)))
+    (dolist (cons-head cons-heads)
+      (emit 'new +lisp-cons-class+)
+      (emit 'dup)
+      (compile-form cons-head 'stack nil))
+    (when list-star-p
+      (compile-form (first (last args)) 'stack nil))
+    (unless list-star-p
+      (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1))
+      (setf cons-heads (nbutlast cons-heads 1)))
+    (dolist (cons-head cons-heads)
+      (declare (ignore cons-head))
+      (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)))
+    (when list-star-p 
+      (apply #'maybe-emit-clear-values args)
+      (emit-move-from-stack target representation))))
+
 (defun p2-list (form target representation)
   (let* ((args (cdr form))
          (len (length args)))
-    (cond ((> len 9) ; list1() through list9() are defined in Lisp.java.
+    (cond ((> len 4) ; list1() through list9() are defined in Lisp.java.
            (compile-function-call form target representation))
           (t
            (cond ((zerop len)
                   (emit-push-nil))
-                 ((= len 1)
-                  (emit 'new +lisp-cons-class+)
-                  (emit 'dup)
-                  (compile-form (first args) 'stack nil)
-                  (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1)))
-                 ((and (>= *speed* *space*)
-                       (< len 4))
-                  (emit 'new +lisp-cons-class+)
-                  (emit 'dup)
-                  (compile-form (first args) 'stack nil)
-                  (emit 'new +lisp-cons-class+)
-                  (emit 'dup)
-                  (compile-form (second args) 'stack nil)
-                  (when (= len 3)
-                    (emit 'new +lisp-cons-class+)
-                    (emit 'dup)
-                    (compile-form (third args) 'stack nil))
-                  (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1))
-                  (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-                  (when (= len 3)
-                    (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))))
-                 (t
-                  (dolist (arg args)
-                    (compile-form arg 'stack nil))
-                  (let ((s (copy-seq "list ")))
-                    (setf (schar s 4) (code-char (+ (char-code #\0) len)))
-                    (emit-invokestatic +lisp-class+ s
-                                       (make-list len :initial-element +lisp-object+)
-                                       +lisp-cons+))))
+                 ((>= 4 len 1)
+		  (cons-for-list/list* args target representation)))
            (unless (every 'single-valued-p args)
              (emit-clear-values))
            (emit-move-from-stack target)))))
 
-(defun cons-for-list* (args target representation)
-  (let ((cons-heads (butlast args 1)))
-    (dolist (cons-head cons-heads)
-      (emit 'new +lisp-cons-class+)
-      (emit 'dup)
-      (compile-form cons-head 'stack nil))
-    (compile-form (first (last args)) 'stack nil)
-    (dolist (cons-head cons-heads)
-      (declare (ignore cons-head))
-      (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)))
-    (apply #'maybe-emit-clear-values args)
-    (emit-move-from-stack target representation)))
-  
 (defun p2-list* (form target representation)
   (let* ((args (cdr form))
          (length (length args)))
-     (cond ((= length 1)
- 	   (compile-forms-and-maybe-emit-clear-values (first args) 'stack nil)
-            (emit-move-from-stack target representation))
-	   ((>= 4 length 2)
-	    (cons-for-list* args target representation))
+     (cond ((>= 4 length 1)
+	    (cons-for-list/list* args target representation t))
           (t
            (compile-function-call form target representation)))))