Use new WHEN-EXTENDED-SEQUENCE-TYPE in MAKE-SEQUENCE, MAP, CONCATENATE, MERGE

NEWS

@@ -8,6 +8,8 @@ changes relative to sbcl-1.3.3:
     metaclasses
   * bug fix: (TYPEP <extended-sequence> <extended-sequence-class>) no longer
     returns NIL in certain situations
+  * bug fix: MAKE-SEQUENCE, MAP, CONCATENATE and MERGE accept class objects as
+    result-type
   * enhancement: who-sets and who-references work on DEFGLOBAL. (lp#1552997)
   * enhancement: CONSTANTP understands backquote.
     e.g. (CONSTANTP '`(0 (,CHAR-CODE-LIMIT))) => T

src/code/seq.lisp

@@ -220,6 +220,24 @@
   `(error 'simple-program-error
           :format-control "~S is too hairy for sequence functions."
           :format-arguments (list ,type-spec)))
+
+(sb!xc:defmacro when-extended-sequence-type
+    ((type-specifier type
+      &key
+      (class (gensym "CLASS"))
+      (prototype (gensym "PROTOTYPE") prototypep))
+     &body body)
+  (once-only ((type-specifier type-specifier) (type type))
+    `(when (csubtypep ,type (specifier-type 'sequence))
+       (binding* ((,class (if (typep ,type-specifier 'class)
+                              ,type-specifier
+                              (find-class ,type-specifier nil))
+                          :exit-if-null)
+                  (,prototype (sb!mop:class-prototype
+                               (sb!pcl:ensure-class-finalized ,class))))
+         ,@(unless prototypep `((ignore ,prototype)))
+         ,@body))))
+
 ) ; EVAL-WHEN
 
 (defun is-a-valid-sequence-type-specifier-p (type)
@@ -343,12 +361,12 @@
                 (length sequence)
                 (sb!sequence:length sequence)))
 
-(defun make-sequence (type length &key (initial-element nil iep))
+(defun make-sequence (result-type length &key (initial-element nil iep))
   #!+sb-doc
-  "Return a sequence of the given TYPE and LENGTH, with elements initialized
-  to INITIAL-ELEMENT."
+  "Return a sequence of the given RESULT-TYPE and LENGTH, with
+  elements initialized to INITIAL-ELEMENT."
   (declare (index length) (explicit-check))
-  (let* ((expanded-type (typexpand type))
+  (let* ((expanded-type (typexpand result-type))
          (adjusted-type
           (typecase expanded-type
             (atom (cond
@@ -393,34 +411,28 @@
            (cond
              (;; is it immediately obvious what the result type is?
               (typep type 'array-type)
-              (progn
-                (aver (= (length (array-type-dimensions type)) 1))
-                (let* ((etype (type-specifier
-                               (array-type-specialized-element-type type)))
-                       (etype (if (eq etype '*) t etype))
-                       (type-length (car (array-type-dimensions type))))
-                  (unless (or (eq type-length '*)
-                              (= type-length length))
-                    (sequence-type-length-mismatch-error type length))
-                  (if iep
-                      (make-array length :element-type etype
-                                  :initial-element initial-element)
-                      (make-array length :element-type etype)))))
+              (aver (= (length (array-type-dimensions type)) 1))
+              (let* ((etype (type-specifier
+                             (array-type-specialized-element-type type)))
+                     (etype (if (eq etype '*) t etype))
+                     (type-length (car (array-type-dimensions type))))
+                (unless (or (eq type-length '*)
+                            (= type-length length))
+                  (sequence-type-length-mismatch-error type length))
+                (if iep
+                    (make-array length :element-type etype
+                                :initial-element initial-element)
+                    (make-array length :element-type etype))))
              (t (sequence-type-too-hairy (type-specifier type)))))
-          ((and (csubtypep type (specifier-type 'sequence))
-                (awhen (if (typep adjusted-type 'class)
-                           adjusted-type
-                           (find-class adjusted-type nil))
-                  (let ((prototype (sb!mop:class-prototype
-                                    (sb!pcl:ensure-class-finalized it))))
-                   ;; This function has the EXPLICIT-CHECK declaration,
-                   ;; so we manually assert that it returns a SEQUENCE.
-                   (the sequence
-                    (if iep
-                        (sb!sequence:make-sequence-like
-                         prototype length :initial-element initial-element)
-                        (sb!sequence:make-sequence-like
-                         prototype length)))))))
+          ((when-extended-sequence-type (expanded-type type :prototype prototype)
+             ;; This function has the EXPLICIT-CHECK declaration, so
+             ;; we manually assert that it returns a SEQUENCE.
+             (the sequence
+                  (if iep
+                      (sb!sequence:make-sequence-like
+                       prototype length :initial-element initial-element)
+                      (sb!sequence:make-sequence-like
+                       prototype length)))))
           (t (bad-sequence-type-error (type-specifier type))))))
 
 ;;;; SUBSEQ
@@ -828,7 +840,6 @@ many elements are copied."
     ;; and not a list or vector.
     (the extended-sequence (values (sb!sequence:nreverse sequence)))))
 
-;;;; CONCATENATE
 
 (defmacro sb!sequence:dosequence ((element sequence &optional return) &body body)
   #!+sb-doc
@@ -856,11 +867,13 @@ many elements are copied."
                       ,@forms))))))))))
 
 
-(defun concatenate (output-type-spec &rest sequences)
+;;;; CONCATENATE
+
+(defun concatenate (result-type &rest sequences)
   #!+sb-doc
   "Return a new sequence of all the argument sequences concatenated together
   which shares no structure with the original argument sequences of the
-  specified OUTPUT-TYPE-SPEC."
+  specified RESULT-TYPE."
   (declare (explicit-check))
   (flet ((concat-to-list* (sequences)
            (let ((result (list nil)))
@@ -889,7 +902,7 @@ many elements are copied."
                (declare (fixnum length))
                (setq lengths (nconc lengths (list length)))
                (setq total-length (+ total-length length))))))
-    (let ((type (specifier-type output-type-spec)))
+    (let ((type (specifier-type result-type)))
       (cond
         ((csubtypep type (specifier-type 'list))
          (cond
@@ -914,18 +927,14 @@ many elements are copied."
                 (concat-to-list* sequences))))
            (t (sequence-type-too-hairy (type-specifier type)))))
         ((csubtypep type (specifier-type 'vector))
-         (concat-to-simple* output-type-spec sequences))
-        ((and (csubtypep type (specifier-type 'sequence))
-              (awhen (find-class output-type-spec nil)
-               ;; This function has the EXPLICIT-CHECK declaration,
-               ;; so we manually assert that it returns a SEQUENCE.
-               (the sequence
-                (apply #'sb!sequence:concatenate
-                       (sb!mop:class-prototype
-                        (sb!pcl:ensure-class-finalized it))
-                       sequences)))))
+         (concat-to-simple* result-type sequences))
+        ((when-extended-sequence-type (result-type type :prototype prototype)
+           ;; This function has the EXPLICIT-CHECK declaration,
+           ;; so we manually assert that it returns a SEQUENCE.
+           (the sequence
+                (apply #'sb!sequence:concatenate prototype sequences))))
         (t
-         (bad-sequence-type-error output-type-spec))))))
+         (bad-sequence-type-error result-type))))))
 
 ;;; Efficient out-of-line concatenate for strings. Compiler transforms
 ;;; CONCATENATE 'STRING &co into these.
@@ -1084,15 +1093,14 @@ many elements are copied."
                   (%map-to-list really-fun sequences))
                  ((csubtypep type (specifier-type 'vector))
                   (%map-to-vector result-type really-fun sequences))
-                 ((and (csubtypep type (specifier-type 'sequence))
-                       (awhen (find-class result-type nil)
-                         ;; This function has the EXPLICIT-CHECK declaration,
-                         ;; so we manually assert that it returns a SEQUENCE.
-                         (the sequence
-                              (apply #'sb!sequence:map
-                                     (sb!mop:class-prototype
-                                      (sb!pcl:ensure-class-finalized it))
-                                     really-fun sequences)))))
+                 ((when-extended-sequence-type
+                      (result-type type :prototype prototype)
+                    ;; This function has the EXPLICIT-CHECK
+                    ;; declaration, so we manually assert that it
+                    ;; returns a SEQUENCE.
+                    (the sequence
+                         (apply #'sb!sequence:map
+                                prototype really-fun sequences))))
                  (t
                   (bad-sequence-type-error result-type))))))
     ;; Handle some easy cases faster

src/code/sort.lisp

@@ -443,13 +443,11 @@
              ;; - use the specialized reffer for inputs + output
              (merge-vectors vector-1 length-1 vector-2 length-2
                             result pred-fun key-fun aref))))
-      ((and (csubtypep type (specifier-type 'sequence))
-            (awhen (find-class result-type nil)
-              (sb!sequence:merge
-               (sb!mop:class-prototype (sb!pcl:ensure-class-finalized it))
-               ;; GF dispatch deals with the erroneous situation wherein
-               ;; either of SEQUENCE1 or SEQUENCE2 is not a sequence.
-               ;; Note that the one builtin method optimizes for NIL as
-               ;; the key fun, and we correctly preserve a NIL here.
-               sequence1 sequence2 pred-fun :key key-fun))))
+      ((when-extended-sequence-type (result-type type :prototype prototype)
+         ;; GF dispatch deals with the erroneous situation wherein
+         ;; either of SEQUENCE1 or SEQUENCE2 is not a sequence.  Note
+         ;; that the one builtin method optimizes for NIL as the key
+         ;; fun, and we correctly preserve a NIL here.
+         (sb!sequence:merge
+          prototype sequence1 sequence2 pred-fun :key key-fun)))
       (t (bad-sequence-type-error result-type)))))

tests/extended-sequences.impure.lisp

@@ -56,8 +56,23 @@
 (defmethod (setf sequence:elt) ((new-value t) (sequence extended-sequence) (index t))
   new-value)
 
-(with-test (:name (make-sequence :type-specifier class))
-  (make-sequence (find-class 'extended-sequence) 3))
-
-(with-test (:name (map make-sequence :result-creation))
+(with-test (:name (map :result-creation))
   (assert (typep (map 'extended-sequence #'1+ '(1 2 3)) 'extended-sequence)))
+
+(with-test (:name (make-sequence :result-type class))
+  (assert (typep (make-sequence (find-class 'extended-sequence) 3)
+                 'extended-sequence)))
+
+(with-test (:name (map :result-type class))
+  (assert (typep (map (find-class 'extended-sequence)
+                      #'1+ '(1 2 3))
+                 'extended-sequence)))
+
+(with-test (:name (merge :result-type class))
+  (assert (typep (merge (find-class 'extended-sequence)
+                        (list 1 2 3) (list 4 5 6) #'<)
+                 'extended-sequence)))
+
+(with-test (:name (concatenate :result-type class))
+  (assert (typep (concatenate (find-class 'extended-sequence) '(1 2) '(3 4))
+                 'extended-sequence)))