From 8a26f905fe58106cd1965a68b072e58b046b6ceb Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@vpn131.vpn.ucm.es>
Date: Thu, 29 May 2008 00:11:26 +0200
Subject: [PATCH] The optimizer for COERCE now uses specialized functions for
 sequence types instead of open coding it every time.

---
 src/cmp/cmpopt.lsp | 10 +++-------
 src/cmp/sysfun.lsp |  1 +
 src/lsp/seq.lsp    | 25 +++++++++++++++++++++++++
 3 files changed, 29 insertions(+), 7 deletions(-)

diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp
index efb9fa843..682123807 100644
--- a/src/cmp/cmpopt.lsp
+++ b/src/cmp/cmpopt.lsp
@@ -257,13 +257,9 @@
 	  ((subtypep type 'sequence)
 	   (multiple-value-bind (elt-type length)
 	       (si::closest-sequence-type type)
-	     (when (eq elt-type 'list)
-	       (setf type 'list))
-	     `(let ((y ,value))
-		(declare (:read-only y))
-		(if (typep y ',type)
-		    y
-		    (concatenate ',type y)))))
+	     (if (eq elt-type 'list)
+		 `(si::coerce-to-list ,value)
+		 `(si::coerce-to-vector ,value ',elt-type ',length))))
 	  ;;
 	  ;; There are no other atomic types to optimize
 	  ((atom type)
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index 5df7fa079..1e88ae42d 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -1457,6 +1457,7 @@ type_of(#0)==t_bitvector")
     si::pprint-logical-block-helper si::pprint-pop-helper
     si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next
     si::structure-type-error si::define-structure
+    si::coerce-to-list si::coerce-to-vector
     #+formatter
     ,@'(
     format-princ format-prin1 format-print-named-character
diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index 9b5bc4ea2..d495fe8bf 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -169,6 +169,31 @@ default value of INITIAL-ELEMENT depends on TYPE."
 	   iterator)
       (rest iterator)))
 
+(defun coerce-to-list (object)
+  (if (listp object)
+      object
+      (do ((it (make-seq-iterator object) (seq-iterator-next object it))
+	   (output nil))
+	  ((null it) (nrevere output))
+	(push (seq-iterator-ref object it) output))))
+
+(defun coerce-to-vector (object elt-type length)
+  (let ((output object))
+    (unless (and (vectorp object)
+		 (eq (array-element-type object) elt-type))
+      (let* ((final-length (if (eq length '*) (length object) length)))
+	(setf output (make-vector elt-type final-length nil nil nil 0))
+	(do ((i (make-seq-iterator object) (seq-iterator-next output i))
+	     (j 0 (1+ j)))
+	    ((= j final-length)
+	     (setf object output))
+	  (declare (index j))
+	  (setf (aref output j) (seq-iterator-ref object i)))))
+    (unless (eq length '*)
+      (unless (= length (length output))
+	(check-type output `(vector ,elt-type (,length)) "coerced object")))
+    output))
+
 (defun concatenate (result-type &rest sequences)
   "Args: (type &rest sequences)
 Returns a new sequence of the specified type, consisting of all elements of