0.8.16.2: TYPE-ERROR for ERROR

[sbcl.git] / src / code / seq.lisp

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 84a9c76..50eec6b 100644 (file)
--- 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)
 
 (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
     (collect ((new-args) (new-declarations) (adjustments))
       (dolist (arg args)
        (case arg

@@ -264,9 +264,23 @@
 (defun make-sequence (type length &key (initial-element nil iep))
   #!+sb-doc
   "Return a sequence of the given TYPE and LENGTH, with elements initialized
 (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))
   (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 ,(if (cdr type)
+                                                  (cdr type)
+                                                  '(*))))
+                   (t type)))
+           (t type)))
+        (type (specifier-type adjusted-type)))

     (cond ((csubtypep type (specifier-type 'list))
           (cond
             ((type= type (specifier-type 'list))
     (cond ((csubtypep type (specifier-type 'list))
           (cond
             ((type= type (specifier-type 'list))

@@ -277,43 +291,42 @@
              (if (= length 0)
                  'nil
                  (sequence-type-length-mismatch-error type length)))
              (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))
             ;; 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))))
                       (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
          (t (bad-sequence-type-error (type-specifier type))))))
 \f
 ;;;; SUBSEQ

@@ -460,6 +473,8 @@
                            (1- source-index)))
             ((= target-index (the fixnum (1- target-start))) target-sequence)
           (declare (fixnum target-index source-index))
                            (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))
           (setf (aref target-sequence target-index)
                 (aref source-sequence source-index))))
        (do ((target-index target-start (1+ target-index))

@@ -468,6 +483,8 @@
                (= source-index (the fixnum source-end)))
            target-sequence)
         (declare (fixnum target-index source-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)))))
 
         (setf (aref target-sequence target-index)
               (aref source-sequence source-index)))))
 

@@ -724,19 +741,20 @@
                                   (and (vectorp x) (= (length x) 0))))
                   sequences)
            'nil
                                   (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))
        (t (sequence-type-too-hairy (type-specifier type)))))
     ((csubtypep type (specifier-type 'vector))
      (apply #'concat-to-simple* output-type-spec sequences))

@@ -1531,7 +1549,7 @@
       (declare (fixnum index))
       (setq splice (cdr (rplacd splice (list (car current)))))
       (setq current (cdr current)))
       (declare (fixnum index))
       (setq splice (cdr (rplacd splice (list (car current)))))
       (setq current (cdr current)))

-    (do ((index 0 (1+ index)))
+    (do ((index start (1+ index)))

        ((or (and end (= index (the fixnum end)))
             (atom current)))
       (declare (fixnum index))
        ((or (and end (= index (the fixnum end)))
             (atom current)))
       (declare (fixnum index))

@@ -1986,10 +2004,10 @@
                                                 (frob sequence nil))))
                         (typecase sequence
                           (simple-vector (frob2))
                                                 (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))
                           (t (vector*-frob sequence))))
                     (declare (type (or index null) p))

-                    (values f (and p (the index (+ p offset))))))))))
+                    (values f (and p (the index (- p offset))))))))))

   (defun %find-position (item sequence-arg from-end start end key test)
     (macrolet ((frob (sequence from-end)
                 `(%find-position item ,sequence
   (defun %find-position (item sequence-arg from-end start end key test)
     (macrolet ((frob (sequence from-end)
                 `(%find-position item ,sequence