X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=777ee4a0c17c3138d086b815edf84e20400dab1a;hb=62be7b271a57e0a125ccb0e68a6dd6cb54c75739;hp=84a9c76799b4c8eb285e9d192cec6a7cf098b210;hpb=2901a9d8c25d8643d17c468c586c21ee3a3251d2;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 84a9c76..777ee4a 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -77,7 +77,7 @@ (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 @@ -264,9 +264,22 @@ (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)) @@ -277,43 +290,42 @@ (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)))))) ;;;; SUBSEQ @@ -724,19 +736,20 @@ (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)) @@ -1986,7 +1999,7 @@ (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))))))))))