X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Fseq.lisp;h=d7d1f437945c47cfdbade90abcd4df40d434cfbe;hb=bcb7a9c9d1cc1566d449efdfd40476d16477a2c9;hp=0d4a153e55e182a2798c91cdd973881512bedfb3;hpb=403bacffd903f8c5787a182f4133cffc69b55dc0;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 0d4a153..d7d1f43 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,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))