Changeset 11840

Timestamp:

05/08/09 17:30:48 (14 years ago)

Author:

vvoutilainen

Message:

Clean up p2-list*.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (1 diff)

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

@@ -6548 +6548 @@
            (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)))))