0.8.12.7: Merge package locks, AKA "what can go wrong with a 3783 line patch?"

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

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 2d0b5a7..d7d1f43 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -264,7 +264,7 @@
 (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* ((adjusted-type
          (typecase type
@@ -290,15 +290,15 @@
              (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.
@@ -472,6 +472,8 @@
                            (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))
@@ -480,6 +482,8 @@
                (= 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)))))
 
@@ -736,19 +740,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))