Make sure quantifiers don't cons

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

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index f2f9cd4..e6abb66 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -266,6 +266,16 @@
            :type '(and list (satisfies list-length)))))
 
 \f
+
+(defun emptyp (sequence)
+  #!+sb-doc
+  "Returns T if SEQUENCE is an empty sequence and NIL
+   otherwise. Signals an error if SEQUENCE is not a sequence."
+  (seq-dispatch sequence
+                (null sequence)
+                (zerop (length sequence))
+                (sb!sequence:emptyp sequence)))
+
 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."
   (seq-dispatch sequence
@@ -788,24 +798,27 @@ many elements are copied."
 \f
 ;;;; CONCATENATE
 
-(defmacro sb!sequence:dosequence ((e sequence &optional return) &body body)
+(defmacro sb!sequence:dosequence ((element sequence &optional return) &body body)
+  #!+sb-doc
+  "Executes BODY with ELEMENT subsequently bound to each element of
+  SEQUENCE, then returns RETURN."
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
     (let ((s sequence)
           (sequence (gensym "SEQUENCE")))
       `(block nil
         (let ((,sequence ,s))
           (seq-dispatch ,sequence
-            (dolist (,e ,sequence ,return) ,@body)
-            (do-vector-data (,e ,sequence ,return) ,@body)
+            (dolist (,element ,sequence ,return) ,@body)
+            (do-vector-data (,element ,sequence ,return) ,@body)
             (multiple-value-bind (state limit from-end step endp elt)
                 (sb!sequence:make-sequence-iterator ,sequence)
               (do ((state state (funcall step ,sequence state from-end)))
                   ((funcall endp ,sequence state limit from-end)
-                   (let ((,e nil))
+                   (let ((,element nil))
                      ,@(filter-dolist-declarations decls)
-                     ,e
+                     ,element
                      ,return))
-                (let ((,e (funcall elt ,sequence state)))
+                (let ((,element (funcall elt ,sequence state)))
                   ,@decls
                   (tagbody
                      ,@forms))))))))))
@@ -851,14 +864,10 @@ many elements are copied."
            ((eq type *empty-type*)
             (bad-sequence-type-error nil))
            ((type= type (specifier-type 'null))
-            (if (every (lambda (x) (or (null x)
-                                       (and (vectorp x) (= (length x) 0))))
-                       sequences)
-                'nil
-                (sequence-type-length-mismatch-error
-                 type
-                 ;; FIXME: circular list issues.
-                 (reduce #'+ sequences :key #'length))))
+            (unless (every #'emptyp sequences)
+              (sequence-type-length-mismatch-error
+               type (reduce #'+ sequences :key #'length))) ; FIXME: circular list issues.
+            '())
            ((cons-type-p type)
             (multiple-value-bind (min exactp)
                 (sb!kernel::cons-type-length-info type)
@@ -1198,17 +1207,20 @@ many elements are copied."
                 ;; from the old seq.lisp into target-seq.lisp.
                 (define-compiler-macro ,name (pred first-seq &rest more-seqs)
                   (let ((elements (make-gensym-list (1+ (length more-seqs))))
-                        (blockname (sb!xc:gensym "BLOCK")))
+                        (blockname (sb!xc:gensym "BLOCK"))
+                        (wrapper (sb!xc:gensym "WRAPPER")))
                     (once-only ((pred pred))
                       `(block ,blockname
-                         (map nil
-                              (lambda (,@elements)
-                                (let ((pred-value (funcall ,pred ,@elements)))
-                                  (,',found-test pred-value
-                                    (return-from ,blockname
-                                      ,',found-result))))
-                              ,first-seq
-                              ,@more-seqs)
+                         (flet ((,wrapper (,@elements)
+                                  (declare (optimize (sb!c::check-tag-existence 0)))
+                                  (let ((pred-value (funcall ,pred ,@elements)))
+                                    (,',found-test pred-value
+                                                   (return-from ,blockname
+                                                     ,',found-result)))))
+                           (declare (inline ,wrapper)
+                                    (dynamic-extent #',wrapper))
+                           (map nil #',wrapper ,first-seq
+                                ,@more-seqs))
                          ,',unfound-result)))))))
   (defquantifier some when pred-value :unfound-result nil :doc
   "Apply PREDICATE to the 0-indexed elements of the sequences, then