From b793fb787df433ac871dd617755f92ba45829e13 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Sat, 13 Sep 2014 19:31:06 +0200 Subject: [PATCH] MERGE calls SB-SEQUENCE:MERGE for extended sequences --- package-data-list.lisp-expr | 4 ++- src/code/sort.lisp | 18 ++++------- src/pcl/sequence.lisp | 73 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 82 insertions(+), 13 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ab9f49f46..76bd4cc0a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2456,7 +2456,9 @@ be submitted as a CDR" "MISMATCH" "SEARCH" "DELETE" "DELETE-IF" "DELETE-IF-NOT" "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT" - "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT")) + "DELETE-DUPLICATES" "REMOVE-DUPLICATES" + + "SORT" "STABLE-SORT" "MERGE")) #s(sb-cold:package-data :name "SB!SYS" diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 278b79c34..14bc87a2d 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -430,16 +430,10 @@ (merge-vectors vector-1 length-1 vector-2 length-2 result predicate key aref)))) ((and (csubtypep type (specifier-type 'sequence)) - (find-class result-type nil)) - (let* ((vector-1 (coerce sequence1 'vector)) - (vector-2 (coerce sequence2 'vector)) - (length-1 (length vector-1)) - (length-2 (length vector-2)) - (temp (make-array (+ length-1 length-2))) - (result (make-sequence result-type (+ length-1 length-2)))) - (declare (vector vector-1 vector-2) (fixnum length-1 length-2)) - (merge-vectors vector-1 length-1 vector-2 length-2 - temp predicate key aref) - (replace result temp) - result)) + (awhen (find-class result-type nil) + (let ((predicate-function (%coerce-callable-to-fun predicate))) + (sb!sequence:merge + (sb!mop:class-prototype + (sb!pcl:ensure-class-finalized it)) + sequence1 sequence2 predicate-function :key key))))) (t (bad-sequence-type-error result-type))))) diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp index 02a183e09..cedc42159 100644 --- a/src/pcl/sequence.lisp +++ b/src/pcl/sequence.lisp @@ -1103,3 +1103,76 @@ ((>= i length) sequence) (funcall setelt (aref vector i) sequence state) (setq state (funcall step sequence state from-end)))))) + +(defgeneric sequence:merge (result-prototype sequence1 sequence2 predicate &key key) + #+sb-doc + (:documentation + "Implements CL:MERGE for extended sequences. + + RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:MERGE 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:MERGE call. RESULT-PROTOTYPE may not be fully initialized and + thus should only be used for dispatch and to determine its class. + + Another difference to CL:MERGE is that PREDICATE is a function, + not a function designator.")) + +(defmethod sequence:merge ((result-prototype sequence) + (sequence1 sequence) (sequence2 sequence) + (predicate function) &key key) + (let ((key-function (when key + (%coerce-callable-to-fun key))) + (result (sequence:make-sequence-like + result-prototype (+ (length sequence1) (length sequence2)))) + endp1 elt1 key1 endp2 elt2 key2) + (sequence:with-sequence-iterator-functions + (step-result endp-result elt-result setelt-result index-result copy-result) (result) ; TODO allow nil and fewer number of elements + (sequence:with-sequence-iterator-functions + (step1 endp1 elt1 setelt1 index1 copy1) (sequence1) + (sequence:with-sequence-iterator-functions + (step2 endp2 elt2 setelt2 index2 copy2) (sequence2) + (labels ((pop/no-key1 () + (unless (setf endp1 (endp1)) + (setf elt1 (elt1)))) + (pop/no-key2 () + (unless (setf endp2 (endp2)) + (setf elt2 (elt2)))) + (pop/key1 () + (unless (setf endp1 (endp1)) + (setf key1 (funcall (truly-the function key-function) + (setf elt1 (elt1)))))) + (pop/key2 () + (unless (setf endp2 (endp2)) + (setf key2 (funcall (truly-the function key-function) + (setf elt2 (elt2)))))) + (pop-one/no-key () + (if (funcall predicate elt2 elt1) ; see comment in MERGE-LIST* + (prog1 elt2 (step2) (pop/no-key2)) + (prog1 elt1 (step1) (pop/no-key1)))) + (pop-one/key () + (if (funcall predicate key2 key1) + (prog1 elt2 (step2) (pop/key2)) + (prog1 elt1 (step1) (pop/key1))))) + (declare (truly-dynamic-extent #'pop/no-key1 #'pop/no-key2 + #'pop/key1 #'pop/key2 + #'pop-one/no-key #'pop-one/key)) + ;; Populate ENDP{1,2}, ELT{1,2} and maybe KEY{1,2}. + (cond (key-function (pop/key1) (pop/key2)) + (t (pop/no-key1) (pop/no-key2))) + (loop with pop-one = (if key-function #'pop-one/key #'pop-one/no-key) do + (cond + (endp2 ; batch-replace rest of SEQUENCE1 if SEQUENCE2 exhausted + (unless endp1 + (replace result sequence1 :start1 (index-result) :start2 (index1))) + (return)) + (endp1 + (unless endp2 + (replace result sequence2 :start1 (index-result) :start2 (index2))) + (return)) + (t + (setelt-result (funcall pop-one)) + (step-result)))))))) + result)) -- 2.11.4.GIT