;;;
;;; FIXME: It might be worth making three cases here, LIST,
;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR.
-;;; It tend to make code run faster but be bigger; some benchmarking
+;;; It tends to make code run faster but be bigger; some benchmarking
;;; is needed to decide.
(sb!xc:defmacro seq-dispatch (sequence list-form array-form)
`(if (listp ,sequence)
(sb!xc:defmacro make-sequence-like (sequence length)
#!+sb-doc
"Return a sequence of the same type as SEQUENCE and the given LENGTH."
- `(make-sequence-of-type (type-of ,sequence) ,length))
-
-(sb!xc:defmacro type-specifier-atom (type)
- #!+sb-doc "Return the broad class of which TYPE is a specific subclass."
- `(if (atom ,type) ,type (car ,type)))
+ `(if (typep ,sequence 'list)
+ (make-list ,length)
+ (progn
+ ;; This is only called from places which have already deduced
+ ;; that the SEQUENCE argument is actually a sequence. So
+ ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE
+ ;; 'VECTOR)), except that this seems to be a performance
+ ;; hotspot.
+ (make-array ,length
+ :element-type (array-element-type ,sequence)))))
+
+(sb!xc:defmacro bad-sequence-type-error (type-spec)
+ `(error 'simple-type-error
+ :datum ,type-spec
+ ;; FIXME: This is actually wrong, and should be something
+ ;; like (SATISFIES IS-A-VALID-SEQUENCE-TYPE-SPECIFIER-P).
+ :expected-type 'sequence
+ :format-control "~S is a bad type specifier for sequences."
+ :format-arguments (list ,type-spec)))
) ; EVAL-WHEN
(vector-of-checked-length-given-length sequence
declared-length))))))
-;;; Given an arbitrary type specifier, return a sane sequence type
-;;; specifier that we can directly match.
-(defun result-type-or-lose (type &optional nil-ok)
- (let ((type (specifier-type type)))
- (cond
- ((eq type *empty-type*)
- (if nil-ok
- nil
- (error 'simple-type-error
- :datum type
- :expected-type '(or vector cons)
- :format-control
- "A NIL output type is invalid for this sequence function."
- :format-arguments ())))
- ((dolist (seq-type '(list string simple-vector bit-vector))
- (when (csubtypep type (specifier-type seq-type))
- (return seq-type))))
- ((csubtypep type (specifier-type 'vector))
- (type-specifier type))
- (t
- (error 'simple-type-error
- :datum type
- :expected-type 'sequence
- :format-control
- "~S is not a legal type specifier for sequence functions."
- :format-arguments (list type))))))
-
(defun signal-index-too-large-error (sequence index)
(let* ((length (length sequence))
- (max-index (and (plusp length) (1- length))))
+ (max-index (and (plusp length)
+ (1- length))))
(error 'index-too-large-error
:datum index
:expected-type (if max-index
;; This seems silly, is there something better?
'(integer (0) (0))))))
-(defun make-sequence-of-type (type length)
- #!+sb-doc "Return a sequence of the given TYPE and LENGTH."
- (declare (fixnum length))
- (case (type-specifier-atom type)
- (list (make-list length))
- ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
- ((string simple-string base-string simple-base-string)
- (make-string length))
- (simple-vector (make-array length))
- ((array simple-array vector)
- (if (listp type)
- (make-array length :element-type (cadr type))
- (make-array length)))
- (t
- (make-sequence-of-type (result-type-or-lose type) length))))
+(defun signal-end-too-large-error (sequence end)
+ (let* ((length (length sequence))
+ (max-end (and (not (minusp length))
+ length)))
+ (error 'end-too-large-error
+ :datum end
+ :expected-type (if max-end
+ `(integer 0 ,max-end)
+ ;; This seems silly, is there something better?
+ '(integer (0) 0)))))
+
+(declaim (inline adjust-count)
+ (ftype (function (sequence-count) index) adjust-count))
+(defun adjust-count (count)
+ (cond ((not count) most-positive-fixnum)
+ ((< count 0) 0)
+ (t count)))
+
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
(let ((type (specifier-type type)))
(cond ((csubtypep type (specifier-type 'list))
(make-list length :initial-element initial-element))
- ((csubtypep type (specifier-type 'string))
- (if iep
- (make-string length :initial-element initial-element)
- (make-string length)))
- ((csubtypep type (specifier-type 'simple-vector))
- (make-array length :initial-element initial-element))
- ((csubtypep type (specifier-type 'bit-vector))
- (if iep
- (make-array length :element-type '(mod 2)
- :initial-element initial-element)
- (make-array length :element-type '(mod 2))))
((csubtypep type (specifier-type 'vector))
(if (typep type 'array-type)
- (let ((etype (type-specifier
- (array-type-specialized-element-type type)))
- (vlen (car (array-type-dimensions type))))
- (if (and (numberp vlen) (/= vlen length))
- (error 'simple-type-error
- ;; These two are under-specified by ANSI.
- :datum (type-specifier type)
- :expected-type (type-specifier type)
- :format-control
- "The length of ~S does not match the specified ~
- length=~S."
- :format-arguments
- (list (type-specifier type) length)))
- (if iep
- (make-array length :element-type etype
- :initial-element initial-element)
- (make-array length :element-type etype)))
- (make-array length :initial-element initial-element)))
- (t (error 'simple-type-error
- :datum type
- :expected-type 'sequence
- :format-control "~S is a bad type specifier for sequences."
- :format-arguments (list type))))))
+ ;; KLUDGE: the above test essentially asks "Do we know
+ ;; what the upgraded-array-element-type is?" [consider
+ ;; (OR STRING BIT-VECTOR)]
+ (progn
+ (aver (= (length (array-type-dimensions type)) 1))
+ (let ((etype (type-specifier
+ (array-type-specialized-element-type type)))
+ (type-length (car (array-type-dimensions type))))
+ (unless (or (eq type-length '*)
+ (= type-length length))
+ (error 'simple-type-error
+ :datum length
+ :expected-type `(eql ,type-length)
+ :format-control "The length requested (~S) ~
+ does not match the length type restriction in ~S."
+ :format-arguments (list length
+ (type-specifier type))))
+ ;; FIXME: These calls to MAKE-ARRAY can't be
+ ;; open-coded, as the :ELEMENT-TYPE argument isn't
+ ;; constant. Probably we ought to write a
+ ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR,
+ ;; 2002-07-22
+ (if iep
+ (make-array length :element-type etype
+ :initial-element initial-element)
+ (make-array length :element-type etype))))
+ ;; We have a subtype of VECTOR, but it isn't an array
+ ;; type. Maybe this should be a BUG instead?
+ (error 'simple-type-error
+ :datum type
+ :expected-type 'sequence
+ :format-control "~S is too hairy for MAKE-SEQUENCE."
+ :format-arguments (list (type-specifier type)))))
+ (t (bad-sequence-type-error (type-specifier type))))))
\f
;;;; SUBSEQ
;;;;
-;;;; The support routines for SUBSEQ are used by compiler transforms, so we
-;;;; worry about dealing with END being supplied or defaulting to NIL
-;;;; at this level.
+;;;; The support routines for SUBSEQ are used by compiler transforms,
+;;;; so we worry about dealing with END being supplied or defaulting
+;;;; to NIL at this level.
(defun vector-subseq* (sequence start &optional end)
(declare (type vector sequence))
(declare (type fixnum start))
(declare (type (or null fixnum) end))
- (when (null end) (setf end (length sequence)))
+ (if (null end)
+ (setf end (length sequence))
+ (unless (<= end (length sequence))
+ (signal-index-too-large-error sequence end)))
(do ((old-index start (1+ old-index))
(new-index 0 (1+ new-index))
(copy (make-sequence-like sequence (- end start))))
((= old-index end) copy)
(declare (fixnum old-index new-index))
- (setf (aref copy new-index) (aref sequence old-index))))
+ (setf (aref copy new-index)
+ (aref sequence old-index))))
(defun list-subseq* (sequence start &optional end)
(declare (type list sequence))
(declare (fixnum index)))
()))))
-;;; SUBSEQ cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value. We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see above).
+;;; SUBSEQ cannot default END to the length of sequence since it is
+;;; not an error to supply NIL for its value. We must test for END
+;;; being NIL in the body of the function, and this is actually done
+;;; in the support routines for other reasons. (See above.)
(defun subseq (sequence start &optional end)
#!+sb-doc
"Return a copy of a subsequence of SEQUENCE starting with element number
(eval-when (:compile-toplevel :execute)
-(sb!xc:defmacro vector-copy-seq (sequence type)
+(sb!xc:defmacro vector-copy-seq (sequence)
`(let ((length (length (the vector ,sequence))))
(declare (fixnum length))
(do ((index 0 (1+ index))
- (copy (make-sequence-of-type ,type length)))
+ (copy (make-sequence-like ,sequence length)))
((= index length) copy)
(declare (fixnum index))
(setf (aref copy index) (aref ,sequence index)))))
(list-copy-seq sequence))
(defun vector-copy-seq* (sequence)
- (vector-copy-seq sequence (type-of sequence)))
+ (declare (type vector sequence))
+ (vector-copy-seq sequence))
\f
;;;; FILL
(declare (fixnum length))
(do ((forward-index 0 (1+ forward-index))
(backward-index (1- length) (1- backward-index))
- (new-sequence (make-sequence-of-type ,type length)))
+ (new-sequence (make-sequence ,type length)))
((= forward-index length) new-sequence)
(declare (fixnum forward-index backward-index))
(setf (aref new-sequence forward-index)
(do ((sequences ,sequences (cdr sequences))
(lengths lengths (cdr lengths))
(index 0)
- (result (make-sequence-of-type ,output-type-spec total-length)))
+ (result (make-sequence ,output-type-spec total-length)))
((= index total-length) result)
(declare (fixnum index))
(let ((sequence (car sequences)))
) ; EVAL-WHEN
\f
-;;; FIXME: Make a compiler macro or transform for this which efficiently
-;;; handles the case of constant 'STRING first argument. (It's not just time
-;;; efficiency, but space efficiency..)
(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."
- (case (type-specifier-atom output-type-spec)
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string
- simple-base-string) ; FIXME: unifying principle here?
- (let ((result (apply #'concat-to-simple* output-type-spec sequences)))
- #!+high-security (aver (typep result output-type-spec))
- result))
- (list (apply #'concat-to-list* sequences))
+ (let ((type (specifier-type output-type-spec)))
+ (cond
+ ((csubtypep type (specifier-type 'vector))
+ (apply #'concat-to-simple* output-type-spec sequences))
+ ((csubtypep type (specifier-type 'list))
+ (apply #'concat-to-list* sequences))
(t
- (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
+ (bad-sequence-type-error output-type-spec)))))
;;; internal frobs
;;; FIXME: These are weird. They're never called anywhere except in
(declare (type index counter))))))
(declare (type index min-len))
(with-map-state sequences
- (let ((result (make-sequence-of-type output-type-spec min-len))
+ (let ((result (make-sequence output-type-spec min-len))
(index 0))
(declare (type index index))
(loop with updated-map-apply-args
;;; length of the output sequence matches any length specified
;;; in RESULT-TYPE.
(defun %map (result-type function first-sequence &rest more-sequences)
- (let ((really-fun (%coerce-callable-to-fun function)))
+ (let ((really-fun (%coerce-callable-to-fun function))
+ (type (specifier-type result-type)))
;; Handle one-argument MAP NIL specially, using ETYPECASE to turn
;; it into something which can be DEFTRANSFORMed away. (It's
;; fairly important to handle this case efficiently, since
;; approach, consing O(N-ARGS) temporary storage (which can have
;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time.
(let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom result-type)
- ((nil) (%map-for-effect really-fun sequences))
- (list (%map-to-list really-fun sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
+ (cond
+ ((eq type *empty-type*) (%map-for-effect really-fun sequences))
+ ((csubtypep type (specifier-type 'list))
+ (%map-to-list really-fun sequences))
+ ((csubtypep type (specifier-type 'vector))
(%map-to-vector result-type really-fun sequences))
(t
- (apply #'map
- (result-type-or-lose result-type t)
- really-fun
- sequences)))))))
+ (bad-sequence-type-error result-type)))))))
(defun map (result-type function first-sequence &rest more-sequences)
- (sequence-of-checked-length-given-type (apply #'%map
- result-type
- function
- first-sequence
- more-sequences)
- ;; (The RESULT-TYPE isn't
- ;; strictly the type of the
- ;; result, because when
- ;; RESULT-TYPE=NIL, the result
- ;; actually has NULL type. But
- ;; that special case doesn't
- ;; matter here, since we only
- ;; look closely at vector
- ;; types; so we can just pass
- ;; RESULT-TYPE straight through
- ;; as a type specifier.)
- result-type))
+ (apply #'%map
+ result-type
+ function
+ first-sequence
+ more-sequences))
;;; KLUDGE: MAP has been rewritten substantially since the fork from
;;; CMU CL in order to give reasonable performance, but this
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(subst-dispatch 'normal)))
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum))
+ (count (adjust-count count))
test-not
old)
(declare (type index length end)
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum))
+ (count (adjust-count count))
test-not
old)
(declare (type index length end)
may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (fixnum count))
(if (listp sequence)
(if from-end
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (fixnum end count))
(if (listp sequence)
(if from-end
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (fixnum end count))
(if (listp sequence)
(if from-end
(vector*-frob (sequence)
`(%find-position-if-vector-macro predicate ,sequence
from-end start end key)))
+ (frobs)))
+ (defun %find-position-if-not (predicate sequence-arg from-end start end key)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position-if-not predicate ,sequence
+ ,from-end start end key))
+ (vector*-frob (sequence)
+ `(%find-position-if-not-vector-macro predicate ,sequence
+ from-end start end key)))
(frobs))))
;;; the user interface to FIND and POSITION: Get all our ducks in a
(def-find-position-if find-if 0)
(def-find-position-if position-if 1))
-;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We don't
-;;; bother to worry about optimizing them.
-;;;
-;;; (Except note that on Sat, Oct 06, 2001 at 04:22:38PM +0100,
-;;; Christophe Rhodes wrote on sbcl-devel
+;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
+;;; didn't bother to worry about optimizing them, except note that on
+;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
+;;; sbcl-devel
;;;
;;; My understanding is that while the :test-not argument is
;;; deprecated in favour of :test (complement #'foo) because of
;;;
;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT
;;; too) within the implementation of SBCL.
+(declaim (inline find-if-not position-if-not))
(macrolet ((def-find-position-if-not (fun-name values-index)
`(defun ,fun-name (predicate sequence
&key from-end (start 0) end key)
(nth-value
,values-index
- (%find-position-if (complement (%coerce-callable-to-fun
- predicate))
- sequence
- from-end
- start
- end
- (effective-find-position-key key))))))
+ (%find-position-if-not (%coerce-callable-to-fun predicate)
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key))))))
+
(def-find-position-if-not find-if-not 0)
(def-find-position-if-not position-if-not 1))
\f
projects / sbcl.git / blobdiff