Index: /trunk/source/level-1/l1-aprims.lisp
===================================================================
--- /trunk/source/level-1/l1-aprims.lisp	(revision 15464)
+++ /trunk/source/level-1/l1-aprims.lisp	(revision 15465)
@@ -145,10 +145,18 @@
   "Return a new list which is EQUAL to LIST."
   (if list
-    (let ((result (cons (car list) '()) ))
-      (do ((x (cdr list) (cdr x))
-           (splice result
-                   (%cdr (%rplacd splice (cons (%car x) '() ))) ))
-          ((atom x) (unless (null x)
-                      (%rplacd splice x)) result)))))
+    (let* ((len (length list)))
+      (declare (fixnum len))
+      (if (>= len (ash 1 16))
+        (do* ((result (%allocate-list 0 len))
+              (in list (%cdr in))
+              (out result (%cdr out)))
+             ((null in) result)
+          (setf (%car out) (%car in)))
+        (let ((result (cons (car list) '()) ))
+          (do ((x (cdr list) (cdr x))
+               (splice result
+                       (%cdr (%rplacd splice (cons (%car x) '() ))) ))
+              ((atom x) (unless (null x)
+                          (%rplacd splice x)) result)))))))
 
 (defun alt-list-length (l)