From: Nathan Froyd Date: Mon, 5 Apr 2010 13:03:03 +0000 (+0000) Subject: 1.0.37.37: fix CONCATENATE FIXME X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=inline;h=9c71b0ad73bd4597d3130553bfbe70c172fe0501;hp=dd92bd1d2fff942e6a38542364be21fa256cb4c0;p=sbcl.git 1.0.37.37: fix CONCATENATE FIXME Collapse helper macros and functions into CONCATENATE as simple FLETs, reducing noise and providing a marginally more efficient CONCATENATE, since we're no longer APPLY'ing and &RESTing lists unnecessarily. --- diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 8c23fe3..6f4ba71 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -803,80 +803,74 @@ ,@decls (tagbody ,@forms)))))))))) - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro concatenate-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))))))))) - -(sb!xc:defmacro concatenate-to-mumble (output-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 ,output-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))))) - -) ; EVAL-WHEN (defun concatenate (output-type-spec &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." - (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)))))) ;;; Efficient out-of-line concatenate for strings. Compiler transforms ;;; CONCATENATE 'STRING &co into these. @@ -900,17 +894,6 @@ result)))) (def %concatenate-to-string character) (def %concatenate-to-base-string base-char)) - -;;; internal frobs -;;; FIXME: These are weird. They're never called anywhere except in -;;; CONCATENATE. It seems to me that the macros ought to just -;;; be expanded directly in CONCATENATE, or in CONCATENATE-STRING -;;; and CONCATENATE-LIST variants. Failing that, these ought to be local -;;; functions (FLET). -(defun concat-to-list* (&rest sequences) - (concatenate-to-list sequences)) -(defun concat-to-simple* (type &rest sequences) - (concatenate-to-mumble type sequences)) ;;;; MAP and MAP-INTO diff --git a/version.lisp-expr b/version.lisp-expr index ce63ee5..ec3a0b2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.37.36" +"1.0.37.37"