(sb!xc:defmacro make-sequence-like (sequence length)
#!+sb-doc
"Return a sequence of the same type as SEQUENCE and the given LENGTH."
- (let ((type (gensym "TYPE-")))
- `(if *type-system-initialized*
- (let ((,type (specifier-type (type-of ,sequence))))
- (if (csubtypep ,type (specifier-type 'list))
- (make-sequence 'list ,length)
- (progn
- (aver (csubtypep ,type (specifier-type 'vector)))
- (aver (array-type-p ,type))
- (setf (array-type-dimensions ,type) (list '*))
- (make-sequence (type-specifier ,type) ,length))))
- (if (typep ,sequence 'string)
- (make-string ,length)
- (error "MAKE-SEQUENCE-LIKE on non-STRING too early in cold-init")))))
+ `(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
:format-control "~S is a bad type specifier for sequences."
:format-arguments (list ,type-spec)))
+(sb!xc:defmacro sequence-type-length-mismatch-error (type length)
+ `(error 'simple-type-error
+ :datum ,length
+ :expected-type (cond ((array-type-p ,type)
+ `(eql ,(car (array-type-dimensions ,type))))
+ ((type= ,type (specifier-type 'null))
+ '(eql 0))
+ ((cons-type-p ,type)
+ '(integer 1))
+ (t (bug "weird type in S-T-L-M-ERROR")))
+ ;; FIXME: this format control causes ugly printing. There's
+ ;; probably some ~<~@:_~> incantation that would make it
+ ;; nicer. -- CSR, 2002-10-18
+ :format-control "The length requested (~S) does not match the type restriction in ~S."
+ :format-arguments (list ,length (type-specifier ,type))))
+
+(sb!xc:defmacro sequence-type-too-hairy (type-spec)
+ ;; FIXME: Should this be a BUG? I'm inclined to think not; there are
+ ;; words that give some but not total support to this position in
+ ;; ANSI. Essentially, we are justified in throwing this on
+ ;; e.g. '(OR SIMPLE-VECTOR (VECTOR FIXNUM)), but maybe not (by ANSI)
+ ;; on '(CONS * (CONS * NULL)) -- CSR, 2002-10-18
+ `(error 'simple-type-error
+ :datum ,type-spec
+ ;; FIXME: as in BAD-SEQUENCE-TYPE-ERROR, this is wrong.
+ :expected-type 'sequence
+ :format-control "~S is too hairy for sequence functions."
+ :format-arguments (list ,type-spec)))
) ; EVAL-WHEN
;;; It's possible with some sequence operations to declare the length
`(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."
(declare (fixnum length))
(let ((type (specifier-type type)))
(cond ((csubtypep type (specifier-type 'list))
- (make-list length :initial-element initial-element))
+ (cond
+ ((type= type (specifier-type 'list))
+ (make-list length :initial-element initial-element))
+ ((eq type *empty-type*)
+ (bad-sequence-type-error nil))
+ ((type= type (specifier-type 'null))
+ (if (= length 0)
+ 'nil
+ (sequence-type-length-mismatch-error type length)))
+ ((csubtypep (specifier-type '(cons nil t)) type)
+ ;; The above is quite a neat way of finding out if
+ ;; there's a type restriction on the CDR of the
+ ;; CONS... if there is, I think it's probably fair to
+ ;; give up; if there isn't, then the list to be made
+ ;; must have a length of more than 0.
+ (if (> length 0)
+ (make-list length :initial-element initial-element)
+ (sequence-type-length-mismatch-error type length)))
+ ;; We'll get here for e.g. (OR NULL (CONS INTEGER *)),
+ ;; which may seem strange and non-ideal, but then I'd say
+ ;; it was stranger to feed that type in to MAKE-SEQUENCE.
+ (t (sequence-type-too-hairy (type-specifier type)))))
((csubtypep type (specifier-type 'vector))
(if (typep type 'array-type)
;; KLUDGE: the above test essentially asks "Do we know
(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))))
+ (sequence-type-length-mismatch-error type length))
;; 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
(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)))))
+ (sequence-type-too-hairy (type-specifier type))))
(t (bad-sequence-type-error (type-specifier type))))))
\f
;;;; SUBSEQ
(eval-when (:compile-toplevel :execute)
-(sb!xc:defmacro vector-reverse (sequence type)
+(sb!xc:defmacro vector-reverse (sequence)
`(let ((length (length ,sequence)))
(declare (fixnum length))
(do ((forward-index 0 (1+ forward-index))
(backward-index (1- length) (1- backward-index))
- (new-sequence (make-sequence ,type length)))
+ (new-sequence (make-sequence-like sequence length)))
((= forward-index length) new-sequence)
(declare (fixnum forward-index backward-index))
(setf (aref new-sequence forward-index)
(list-reverse-macro sequence))
(defun vector-reverse* (sequence)
- (vector-reverse sequence (type-of sequence)))
+ (vector-reverse sequence))
\f
;;;; NREVERSE
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. And
+ ;; rightward-drift.
+ (reduce #'+
+ (mapcar #'length
+ sequences)))))
+ ((csubtypep (specifier-type '(cons nil t)) type)
+ (if (notevery (lambda (x) (or (null x)
+ (and (vectorp x) (= (length x) 0))))
+ sequences)
+ (apply #'concat-to-list* sequences)
+ (sequence-type-length-mismatch-error type 0)))
+ (t (sequence-type-too-hairy (type-specifier type)))))
((csubtypep type (specifier-type 'vector))
(apply #'concat-to-simple* output-type-spec sequences))
- ((csubtypep type (specifier-type 'list))
- (apply #'concat-to-list* sequences))
(t
(bad-sequence-type-error output-type-spec)))))
(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
`(let* ((sequence ,(if reverse?
'(reverse (the list sequence))
'sequence))
+ (%start ,(if reverse? '(- length end) 'start))
+ (%end ,(if reverse? '(- length start) 'end))
(splice (list nil))
(results (do ((index 0 (1+ index))
(before-start splice))
- ((= index (the fixnum start)) before-start)
+ ((= index (the fixnum %start)) before-start)
(declare (fixnum index))
(setq splice
(cdr (rplacd splice (list (pop sequence))))))))
- (do ((index start (1+ index))
+ (do ((index %start (1+ index))
(this-element)
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum %end)) (= number-zapped (the fixnum count)))
(do ((index index (1+ index)))
((null sequence)
,(if reverse?
(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
which case the one later in the sequence is discarded. The resulting
sequence is returned.
- The :TEST-NOT argument is depreciated."
+ The :TEST-NOT argument is deprecated."
(declare (fixnum start))
(seq-dispatch sequence
(if sequence
discarded. The resulting sequence, which may be formed by destroying the
given sequence, is returned.
- The :TEST-NOT argument is depreciated."
+ The :TEST-NOT argument is deprecated."
(seq-dispatch sequence
(if sequence
(list-delete-duplicates* sequence test test-not key from-end start end))
(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
- (nreverse (nlist-substitute*
- new old (nreverse (the list sequence))
- test test-not start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute*
+ new old (nreverse (the list sequence))
+ test test-not (- length end) (- length start)
+ count key)))
(nlist-substitute* new old sequence
test test-not start end count key))
(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
- (nreverse (nlist-substitute-if*
- new test (nreverse (the list sequence))
- start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if*
+ new test (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
(nlist-substitute-if* new test sequence
start end count key))
(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
- (nreverse (nlist-substitute-if-not*
- new test (nreverse (the list sequence))
- start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if-not*
+ new test (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
(nlist-substitute-if-not* new test sequence
start end count key))
(if from-end
;;; perhaps it's worth optimizing the -if-not versions in the same
;;; way as the others?
;;;
-;;; That sounds reasonable, so if someone wants to submit patches to
-;;; make the -IF-NOT functions compile as efficiently as the
-;;; corresponding -IF variants do, go for it. -- WHN 2001-10-06)
-;;;
-;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT
-;;; too) within the implementation of SBCL.
+;;; FIXME: Maybe remove uses of these deprecated functions (and
+;;; definitely of :TEST-NOT) 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
projects / sbcl.git / blobdiff