- (let ((type (specifier-type output-type-spec)))
- (cond
- ((csubtypep type (specifier-type 'list))
- (cond
- ((type= type (specifier-type 'list))
- (apply #'concat-to-list* sequences))
- ((eq type *empty-type*)
- (bad-sequence-type-error nil))
- ((type= type (specifier-type 'null))
- (if (every (lambda (x) (or (null x)
- (and (vectorp x) (= (length x) 0))))
- sequences)
- 'nil
- (sequence-type-length-mismatch-error
- type
- ;; FIXME: circular list issues.
- (reduce #'+ sequences :key #'length))))
- ((cons-type-p type)
- (multiple-value-bind (min exactp)
- (sb!kernel::cons-type-length-info type)
- (let ((length (reduce #'+ sequences :key #'length)))
- (if exactp
- (unless (= length min)
- (sequence-type-length-mismatch-error type length))
- (unless (>= length min)
- (sequence-type-length-mismatch-error type length)))
- (apply #'concat-to-list* sequences))))
- (t (sequence-type-too-hairy (type-specifier type)))))
- ((csubtypep type (specifier-type 'vector))
- (apply #'concat-to-simple* output-type-spec sequences))
- ((and (csubtypep type (specifier-type 'sequence))
- (find-class output-type-spec nil))
- (coerce (apply #'concat-to-simple* 'vector sequences) output-type-spec))
- (t
- (bad-sequence-type-error output-type-spec)))))
+ (flet ((concat-to-list* (sequences)
+ (let ((result (list nil)))
+ (do ((sequences sequences (cdr sequences))
+ (splice result))
+ ((null sequences) (cdr result))
+ (let ((sequence (car sequences)))
+ (sb!sequence:dosequence (e sequence)
+ (setq splice (cdr (rplacd splice (list e)))))))))
+ (concat-to-simple* (type-spec sequences)
+ (do ((seqs sequences (cdr seqs))
+ (total-length 0)
+ (lengths ()))
+ ((null seqs)
+ (do ((sequences sequences (cdr sequences))
+ (lengths lengths (cdr lengths))
+ (index 0)
+ (result (make-sequence type-spec total-length)))
+ ((= index total-length) result)
+ (declare (fixnum index))
+ (let ((sequence (car sequences)))
+ (sb!sequence:dosequence (e sequence)
+ (setf (aref result index) e)
+ (incf index)))))
+ (let ((length (length (car seqs))))
+ (declare (fixnum length))
+ (setq lengths (nconc lengths (list length)))
+ (setq total-length (+ total-length length))))))
+ (let ((type (specifier-type output-type-spec)))
+ (cond
+ ((csubtypep type (specifier-type 'list))
+ (cond
+ ((type= type (specifier-type 'list))
+ (concat-to-list* sequences))
+ ((eq type *empty-type*)
+ (bad-sequence-type-error nil))
+ ((type= type (specifier-type 'null))
+ (if (every (lambda (x) (or (null x)
+ (and (vectorp x) (= (length x) 0))))
+ sequences)
+ 'nil
+ (sequence-type-length-mismatch-error
+ type
+ ;; FIXME: circular list issues.
+ (reduce #'+ sequences :key #'length))))
+ ((cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (let ((length (reduce #'+ sequences :key #'length)))
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (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))
+ (find-class output-type-spec nil))
+ (coerce (concat-to-simple* 'vector sequences) output-type-spec))
+ (t
+ (bad-sequence-type-error output-type-spec))))))