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

[Ville Voutilainen]

Author: vvoutilainen
Date: Fri May  8 13:30:48 2009
New Revision: 11840

Log:
Clean up p2-list*.


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 13:30:48 2009
@@ -6547,57 +6547,27 @@
              (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))
-          ((= length 2)
-           (let ((arg1 (first args))
-                 (arg2 (second args)))
-             (emit 'new +lisp-cons-class+)
-             (emit 'dup)
-             (compile-form arg1 'stack nil)
-             (compile-form arg2 'stack nil)
-             (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-             (maybe-emit-clear-values arg1 arg2)
-             (emit-move-from-stack target representation)))
-          ((= length 3)
-           (let ((arg1 (first args))
-                 (arg2 (second args))
-                 (arg3 (third args)))
-             (emit 'new +lisp-cons-class+)
-             (emit 'dup)
-             (compile-form arg1 'stack nil)
-             (emit 'new +lisp-cons-class+)
-             (emit 'dup)
-             (compile-form arg2 'stack nil)
-             (compile-form arg3 'stack nil)
-             (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-             (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-             (maybe-emit-clear-values arg1 arg2 arg3)
-             (emit-move-from-stack target representation)))
-          ((= length 4)
-           (let ((arg1 (first args))
-                 (arg2 (second args))
-                 (arg3 (third args))
-                 (arg4 (fourth args)))
-             (emit 'new +lisp-cons-class+)
-             (emit 'dup)
-             (compile-form arg1 'stack nil)
-             (emit 'new +lisp-cons-class+)
-             (emit 'dup)
-             (compile-form arg2 'stack nil)
-             (emit 'new +lisp-cons-class+)
-             (emit 'dup)
-             (compile-form arg3 'stack nil)
-             (compile-form arg4 'stack nil)
-             (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-             (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-             (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
-             (maybe-emit-clear-values arg1 arg2 arg3 arg4)
-             (emit-move-from-stack target representation)))
+     (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))
           (t
            (compile-function-call form target representation)))))