0.6.11.37:

[sbcl.git] / src / compiler / seqtran.lisp

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3bd162c..d72020d 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -249,7 +249,7 @@
                     `(if (funcall test e ',(car els))
                          ',els
                          ,(frob (cdr els)))
-                    'nil)))
+                    nil)))
        (frob val)))))
 
 ;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER
@@ -279,8 +279,8 @@
       (cond (test
             (unless (continuation-function-is test '(eq))
               (give-up-ir1-transform)))
-           ((types-intersect (continuation-type item)
-                             (specifier-type 'number))
+           ((types-equal-or-intersect (continuation-type item)
+                                      (specifier-type 'number))
             (give-up-ir1-transform "Item might be a number.")))
       `(,eq-fun item list))))
 
@@ -366,8 +366,10 @@
                (eq (global-var-kind leaf) :global-function)
                (not (null (member (leaf-name leaf) names :test #'equal))))))))
 
-;;; If Cont is a constant continuation, the return the constant value. If
-;;; it is null, then return default, otherwise quietly GIVE-UP.
+;;; If CONT is a constant continuation, the return the constant value.
+;;; If it is null, then return default, otherwise quietly give up the
+;;; IR1 transform.
+;;;
 ;;; ### Probably should take an ARG and flame using the NAME.
 (defun constant-value-or-lose (cont &optional default)
   (declare (type (or continuation null) cont))
@@ -378,11 +380,12 @@
         (give-up-ir1-transform))))
 
 #|
-;;; This is a frob whose job it is to make it easier to pass around the
-;;; arguments to IR1 transforms. It bundles together the name of the argument
-;;; (which should be referenced in any expansion), and the continuation for
-;;; that argument (or NIL if unsupplied.)
-(defstruct (arg (:constructor %make-arg (name cont)))
+;;; This is a frob whose job it is to make it easier to pass around
+;;; the arguments to IR1 transforms. It bundles together the name of
+;;; the argument (which should be referenced in any expansion), and
+;;; the continuation for that argument (or NIL if unsupplied.)
+(defstruct (arg (:constructor %make-arg (name cont))
+               (:copier nil))
   (name nil :type symbol)
   (cont nil :type (or continuation null)))
 (defmacro make-arg (name)
@@ -419,7 +422,7 @@
             (eql (continuation-value cont) x)))
       (eql default x)))
 
-(defstruct iterator
+(defstruct (iterator (:copier nil))
   ;; The kind of iterator.
   (kind nil (member :normal :result))
   ;; A list of LET* bindings to create the initial state.
@@ -539,7 +542,8 @@
                   ,body))
               ((not (csubtypep (continuation-type fun-cont)
                                (specifier-type 'function)))
-               (when (policy *compiler-error-context* (> speed brevity))
+               (when (policy *compiler-error-context*
+                             (> speed inhibit-warnings))
                  (compiler-note
                   "~S may not be a function, so must coerce at run-time."
                   n-fun))
@@ -616,7 +620,7 @@
                                                     (- start2 start1))))))
                    index)
                   (t nil))
-            ,(if equalp 'end1 'nil))))))
+            ,(if equalp 'end1 nil))))))
 
 (dolist (stuff '((string=* not)
                 (string/=* identity)))
@@ -704,3 +708,21 @@
         (declare (type index start ,@(all-lengths)))
         ,@(forms)
         res))))
+\f
+;;;; CONS accessor DERIVE-TYPE optimizers
+
+(defoptimizer (car derive-type) ((cons))
+  (let ((type (continuation-type cons))
+       (null-type (specifier-type 'null)))
+    (cond ((eq type null-type)
+          null-type)
+         ((cons-type-p type)
+          (cons-type-car-type type)))))
+
+(defoptimizer (cdr derive-type) ((cons))
+  (let ((type (continuation-type cons))
+       (null-type (specifier-type 'null)))
+    (cond ((eq type null-type)
+          null-type)
+         ((cons-type-p type)
+          (cons-type-cdr-type type)))))