#!+sb-doc
"Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
sequence of type RESULT-TYPE using PREDICATE to order the elements."
- (if (eq result-type 'list)
- (let ((result (merge-lists* (coerce sequence1 'list)
- (coerce sequence2 'list)
- predicate key)))
- result)
- (let* ((vector-1 (coerce sequence1 'vector))
- (vector-2 (coerce sequence2 'vector))
- (length-1 (length vector-1))
- (length-2 (length vector-2))
- (result (make-sequence result-type
- (+ length-1 length-2))))
- (declare (vector vector-1 vector-2)
- (fixnum length-1 length-2))
-
- #!+high-security (aver (typep result result-type))
- (if (and (simple-vector-p result)
- (simple-vector-p vector-1)
- (simple-vector-p vector-2))
- (merge-vectors vector-1 length-1 vector-2 length-2
- result predicate key svref)
- (merge-vectors vector-1 length-1 vector-2 length-2
- result predicate key aref)))))
+ (let ((type (specifier-type result-type)))
+ (cond
+ ((csubtypep type (specifier-type 'list))
+ (let ((result (merge-lists* (coerce sequence1 'list)
+ (coerce sequence2 'list)
+ predicate key)))
+ result))
+ ((csubtypep type (specifier-type 'vector))
+ (let* ((vector-1 (coerce sequence1 'vector))
+ (vector-2 (coerce sequence2 'vector))
+ (length-1 (length vector-1))
+ (length-2 (length vector-2))
+ (result (make-sequence result-type
+ (+ length-1 length-2))))
+ (declare (vector vector-1 vector-2)
+ (fixnum length-1 length-2))
+ (if (and (simple-vector-p result)
+ (simple-vector-p vector-1)
+ (simple-vector-p vector-2))
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key svref)
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key aref))))
+ (t (bad-sequence-type-error result-type)))))
(assert-type-error (concatenate 'simple-array "foo" "bar"))
(assert-type-error (map 'simple-array #'identity '(1 2 3)))
(assert-type-error (coerce '(1 2 3) 'simple-array))
+ (assert-type-error (merge 'simple-array '(1 3) '(2 4) '<))
;; but COERCE has an exemption clause:
- (assert (string= "foo" (coerce "foo" 'simple-array)))))
+ (assert (string= "foo" (coerce "foo" 'simple-array)))
+ ;; ... though not in all cases.
+ (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
+
+;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
+;;; with user-defined types until sbcl-0.7.8.11
+(deftype list-typeoid () 'list)
+(assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<)))
+;;; and also with types that weren't precicely LIST
+(assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<)))
\f
;;; success
(quit :unix-status 104)