;; 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
(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
: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)))))
+
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
"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)))
;;;; 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)
(end end)
:force-inline t
:check-fill-pointer t)
- (macrolet ((frob ()
- `(locally (declare (optimize (safety 0) (speed 3)))
- (do ((i start (1+ i)))
- ((= i end) sequence)
- (declare (index i))
- (setf (aref data i) item)))))
- (etypecase data
- #!+sb-unicode
- ((simple-array character (*))
- (let ((item (locally (declare (optimize (safety 3)))
- (the character item))))
- (frob)))
- ((simple-array base-char (*))
- (let ((item (locally (declare (optimize (safety 3)))
- (the base-char item))))
- (frob)))))))
+ ;; DEFTRANSFORM for FILL will turn these into
+ ;; calls to UB*-BASH-FILL.
+ (etypecase data
+ #!+sb-unicode
+ ((simple-array character (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the character item))))
+ (fill data item :start start :end end)))
+ ((simple-array base-char (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the base-char item))))
+ (fill data item :start start :end end))))))
(defun fill (sequence item &key (start 0) end)
#!+sb-doc
,@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
\f
(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))
\f
;;;; MAP and MAP-INTO
(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)
(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)
(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
projects / sbcl.git / blobdiff