X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=cc0267168121412577d70a91e81dabe9c9d24469;hb=41cb424785ec6daf0263acb1a6a8af9d41708990;hp=7cc96924a0742245d99102981a6c2959df5a010c;hpb=cfc3b695e6452907fef6492710777511ac4af979;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 7cc9692..cc02671 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -224,6 +224,7 @@ ;; This seems silly, is there something better? '(integer 0 (0)))))) +(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error)) (defun sequence-bounding-indices-bad-error (sequence start end) (let ((size (length sequence))) (error 'bounding-indices-bad-error @@ -232,6 +233,7 @@ (integer ,start ,size)) :object sequence))) +(declaim (ftype (function (t t t) nil) array-bounding-indices-bad-error)) (defun array-bounding-indices-bad-error (array start end) (let ((size (array-total-size array))) (error 'bounding-indices-bad-error @@ -239,6 +241,16 @@ :expected-type `(cons (integer 0 ,size) (integer ,start ,size)) :object array))) + +(declaim (ftype (function (t) nil) circular-list-error)) +(defun circular-list-error (list) + (let ((*print-circle* t)) + (error 'simple-type-error + :format-control "List is circular:~% ~S" + :format-arguments (list list) + :datum list + :type '(and list (satisfies list-length))))) + (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -284,17 +296,18 @@ "Return a sequence of the given TYPE and LENGTH, with elements initialized to INITIAL-ELEMENT." (declare (fixnum length)) - (let* ((adjusted-type - (typecase type + (let* ((expanded-type (typexpand type)) + (adjusted-type + (typecase expanded-type (atom (cond - ((eq type 'string) '(vector character)) - ((eq type 'simple-string) '(simple-array character (*))) + ((eq expanded-type 'string) '(vector character)) + ((eq expanded-type 'simple-string) '(simple-array character (*))) (t type))) (cons (cond - ((eq (car type) 'string) `(vector character ,@(cdr type))) - ((eq (car type) 'simple-string) - `(simple-array character ,(if (cdr type) - (cdr type) + ((eq (car expanded-type) 'string) `(vector character ,@(cdr expanded-type))) + ((eq (car expanded-type) 'simple-string) + `(simple-array character ,(if (cdr expanded-type) + (cdr expanded-type) '(*)))) (t type))) (t type))) @@ -364,38 +377,17 @@ ;;;; so we worry about dealing with END being supplied or defaulting ;;;; to NIL at this level. -(defun string-subseq* (sequence start end) - (with-array-data ((data sequence) - (start start) - (end end) - :force-inline t - :check-fill-pointer t) - (declare (optimize (speed 3) (safety 0))) - (string-dispatch ((simple-array character (*)) - (simple-array base-char (*)) - (vector nil)) - data - (subseq data start end)))) - (defun vector-subseq* (sequence start end) (declare (type vector sequence)) (declare (type index start) - (type (or null index) end)) + (type (or null index) end) + (optimize speed)) (with-array-data ((data sequence) (start start) (end end) :check-fill-pointer t :force-inline t) - (let* ((copy (%make-sequence-like sequence (- end start))) - (setter (!find-data-vector-setter copy)) - (reffer (!find-data-vector-reffer data))) - (declare (optimize (speed 3) (safety 0))) - (do ((old-index start (1+ old-index)) - (new-index 0 (1+ new-index))) - ((= old-index end) copy) - (declare (index old-index new-index)) - (funcall setter copy new-index - (funcall reffer data old-index)))))) + (funcall (!find-vector-subseq-fun data) data start end))) (defun list-subseq* (sequence start end) (declare (type list sequence) @@ -791,91 +783,98 @@ ,@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))))) - -;;; 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)) + (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. +(macrolet ((def (name element-type) + `(defun ,name (&rest sequences) + (declare (dynamic-extent sequences) + (optimize speed) + (optimize (sb!c::insert-array-bounds-checks 0))) + (let* ((lengths (mapcar #'length sequences)) + (result (make-array (the integer (apply #'+ lengths)) + :element-type ',element-type)) + (start 0)) + (declare (index start)) + (dolist (seq sequences) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*)) + t) + seq + (replace result seq :start1 start)) + (incf start (the index (pop lengths)))) + result)))) + (def %concatenate-to-string character) + (def %concatenate-to-base-string base-char)) ;;;; MAP and MAP-INTO @@ -2163,7 +2162,7 @@ (macrolet (;; shared logic for defining %FIND-POSITION and ;; %FIND-POSITION-IF in terms of various inlineable cases ;; of the expression defined in FROB and VECTOR*-FROB - (frobs () + (frobs (&optional bit-frob) `(seq-dispatch sequence-arg (frob sequence-arg from-end) (with-array-data ((sequence sequence-arg :offset-var offset) @@ -2171,14 +2170,27 @@ (end end) :check-fill-pointer t) (multiple-value-bind (f p) - (macrolet ((frob2 () '(if from-end - (frob sequence t) - (frob sequence nil)))) + (macrolet ((frob2 () `(if from-end + (frob sequence t) + (frob sequence nil)))) (typecase sequence #!+sb-unicode ((simple-array character (*)) (frob2)) ((simple-array base-char (*)) (frob2)) - (t (vector*-frob sequence)))) + ,@(when bit-frob + `((simple-bit-vector + (if (and (eq #'identity key) + (or (eq #'eq test) + (eq #'eql test) + (eq #'equal test))) + (let ((p (%bit-position (the bit item) sequence + from-end start end))) + (if p + (values item p) + (values nil nil))) + (vector*-frob sequence))))) + (t + (vector*-frob sequence)))) (declare (type (or index null) p)) (values f (and p (the index (- p offset))))))))) (defun %find-position (item sequence-arg from-end start end key test) @@ -2188,7 +2200,7 @@ (vector*-frob (sequence) `(%find-position-vector-macro item ,sequence from-end start end key test))) - (frobs))) + (frobs t))) (defun %find-position-if (predicate sequence-arg from-end start end key) (macrolet ((frob (sequence from-end) `(%find-position-if predicate ,sequence