(sb!xc:defmacro define-sequence-traverser (name args &body body)
(multiple-value-bind (body declarations docstring)
- (parse-body body t)
+ (parse-body body :doc-string-allowed t)
(collect ((new-args) (new-declarations) (adjustments))
(dolist (arg args)
(case arg
(defun make-sequence (type length &key (initial-element nil iep))
#!+sb-doc
"Return a sequence of the given TYPE and LENGTH, with elements initialized
- to :INITIAL-ELEMENT."
+ to INITIAL-ELEMENT."
(declare (fixnum length))
- (let ((type (specifier-type type)))
+ (let* ((adjusted-type
+ (typecase type
+ (atom (cond
+ ((eq type 'string) '(vector character))
+ ((eq 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 ,@(when (cdr type)
+ (list (cdr type)))))
+ (t type)))
+ (t type)))
+ (type (specifier-type adjusted-type)))
(cond ((csubtypep type (specifier-type 'list))
(cond
((type= type (specifier-type 'list))
(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)))
+ ((cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (make-list length :initial-element initial-element)))
;; 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
- ;; 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)))
- (etype (if (eq etype '*) t etype))
+ (cond
+ (;; is it immediately obvious what the result type is?
+ (typep type 'array-type)
+ (progn
+ (aver (= (length (array-type-dimensions type)) 1))
+ (let* ((etype (type-specifier
+ (array-type-specialized-element-type type)))
+ (etype (if (eq etype '*) t etype))
(type-length (car (array-type-dimensions type))))
- (unless (or (eq type-length '*)
- (= type-length length))
- (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
- ;; 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))))
- (sequence-type-too-hairy (type-specifier type))))
+ (unless (or (eq type-length '*)
+ (= type-length length))
+ (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
+ ;; 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)))))
+ (t (sequence-type-too-hairy (type-specifier type)))))
(t (bad-sequence-type-error (type-specifier type))))))
\f
;;;; SUBSEQ
(1- source-index)))
((= target-index (the fixnum (1- target-start))) target-sequence)
(declare (fixnum target-index source-index))
+ ;; disable bounds checking
+ (declare (optimize (safety 0)))
(setf (aref target-sequence target-index)
(aref source-sequence source-index))))
(do ((target-index target-start (1+ target-index))
(= source-index (the fixnum source-end)))
target-sequence)
(declare (fixnum target-index source-index))
+ ;; disable bounds checking
+ (declare (optimize (safety 0)))
(setf (aref target-sequence target-index)
(aref source-sequence source-index)))))
(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)))
+ (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))
(frob sequence nil))))
(typecase sequence
(simple-vector (frob2))
- (simple-string (frob2))
+ (simple-base-string (frob2))
(t (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (+ p offset))))))))))
projects / sbcl.git / blobdiff