[Sbcl-commits] master: CONCATENATE calls SB-SEQUENCE:CONCATENATE for extended sequences

[Jan M. <sc...@us...>]

The branch "master" has been updated in SBCL:
       via  7f7b6be005a44b0e1af8d6e2752be901887fc764 (commit)
      from  0583c47459320ebe9fd7ede055ca93a1853a235d (commit)

- Log -----------------------------------------------------------------
commit 7f7b6be005a44b0e1af8d6e2752be901887fc764
Author: Jan Moringen <jmo...@te...>
Date:   Sat Sep 13 17:43:42 2014 +0200

    CONCATENATE calls SB-SEQUENCE:CONCATENATE for extended sequences
---
 package-data-list.lisp-expr |    2 +-
 src/code/seq.lisp           |    8 ++++++--
 src/pcl/sequence.lisp       |   25 +++++++++++++++++++++++++
 3 files changed, 32 insertions(+), 3 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index a6ed058..ab9f49f 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2452,7 +2452,7 @@ be submitted as a CDR"
                "SUBSEQ" "COPY-SEQ" "FILL"
                "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT"
                "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT"
-               "REPLACE" "REVERSE" "NREVERSE" "REDUCE"
+               "REPLACE" "REVERSE" "NREVERSE" "CONCATENATE" "REDUCE"
                "MISMATCH" "SEARCH"
                "DELETE" "DELETE-IF" "DELETE-IF-NOT"
                "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT"
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index dbeb4d3..d469533 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -918,8 +918,11 @@ many elements are copied."
         ((csubtypep type (specifier-type 'vector))
          (concat-to-simple* output-type-spec sequences))
         ((and (csubtypep type (specifier-type 'sequence))
-              (find-class output-type-spec nil))
-         (coerce (concat-to-simple* 'vector sequences) output-type-spec))
+              (awhen (find-class output-type-spec nil)
+                (apply #'sb!sequence:concatenate
+                       (sb!mop:class-prototype
+                        (sb!pcl:ensure-class-finalized it))
+                       sequences))))
         (t
          (bad-sequence-type-error output-type-spec))))))
 
@@ -946,6 +949,7 @@ many elements are copied."
                   result))))
   (def %concatenate-to-string character)
   (def %concatenate-to-base-string base-char))
+
 
 ;;;; MAP
 
diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp
index 27c19e1..02a183e 100644
--- a/src/pcl/sequence.lisp
+++ b/src/pcl/sequence.lisp
@@ -728,6 +728,31 @@
   (let ((result (copy-seq sequence)))
     (sequence:nreverse result)))
 
+(defgeneric sequence:concatenate (result-prototype &rest sequences)
+  #+sb-doc
+  (:documentation
+   "Implements CL:CONCATENATE for extended sequences.
+
+    RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:CONCATENATE
+    but receives a prototype instance of an extended sequence class
+    instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
+    methods on this generic function specify how extended sequence
+    classes act when they are specified as the result type in a
+    CL:CONCATENATE call. RESULT-PROTOTYPE may not be fully initialized
+    and thus should only be used for dispatch and to determine its
+    class."))
+
+(defmethod sequence:concatenate ((result-prototype sequence) &rest sequences)
+  (let* ((lengths (mapcar #'length sequences))
+         (result (sequence:make-sequence-like
+                  result-prototype (reduce #'+ lengths))))
+    (loop with index = 0
+       for sequence in sequences
+       for length in lengths do
+         (replace result sequence :start1 index)
+         (incf index length))
+    result))
+
 (defgeneric sequence:reduce
     (function sequence &key from-end start end initial-value)
   (:argument-precedence-order sequence function))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL