0.6.10.15:

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

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 2f2755f..9c853d1 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -15,9 +15,6 @@
 ;;;; files for more information.
 
 (in-package "SB!C")
-
-(file-comment
-  "$Header$")
 \f
 ;;;; interface for obtaining results of constant folding
 
@@ -642,7 +639,7 @@
 #!+sb-show
 (defvar *show-transforms-p* nil)
 
-;;; Do IR1 optimizations on a Combination node.
+;;; Do IR1 optimizations on a COMBINATION node.
 (declaim (ftype (function (combination) (values)) ir1-optimize-combination))
 (defun ir1-optimize-combination (node)
   (when (continuation-reoptimize (basic-combination-fun node))
@@ -844,7 +841,23 @@
        ((valid-function-use call type
                             :argument-test #'always-subtypep
                             :result-test #'always-subtypep
-                            :error-function #'compiler-warning
+                            ;; KLUDGE: Common Lisp is such a dynamic
+                            ;; language that all we can do here in
+                            ;; general is issue a STYLE-WARNING. It
+                            ;; would be nice to issue a full WARNING
+                            ;; in the special case of of type
+                            ;; mismatches within a compilation unit
+                            ;; (as in section 3.2.2.3 of the spec)
+                            ;; but at least as of sbcl-0.6.11, we
+                            ;; don't keep track of whether the
+                            ;; mismatched data came from the same
+                            ;; compilation unit, so we can't do that.
+                            ;; -- WHN 2001-02-11
+                            ;;
+                            ;; FIXME: Actually, I think we could
+                            ;; issue a full WARNING if the call
+                            ;; violates a DECLAIM FTYPE.
+                            :error-function #'compiler-style-warning
                             :warning-function #'compiler-note)
         (assert-call-type call type)
         (maybe-terminate-block call ir1-p)
@@ -887,8 +900,8 @@
                           (and dest (not (if-p dest))))))
                (let ((name (leaf-name leaf)))
                  (when (symbolp name)
-                   (let ((dums (loop repeat (length (combination-args call))
-                                     collect (gensym))))
+                   (let ((dums (make-gensym-list (length
+                                                  (combination-args call)))))
                      (transform-call call
                                      `(lambda ,dums
                                         (,name ,@dums))))))))))))
@@ -923,8 +936,8 @@
         (constrained (function-type-p type))
         (table (component-failed-optimizations *component-being-compiled*))
         (flame (if (transform-important transform)
-                   (policy node (>= speed brevity))
-                 (policy node (> speed brevity))))
+                   (policy node (>= speed inhibit-warnings))
+                   (policy node (> speed inhibit-warnings))))
         (*compiler-error-context* node))
     (cond ((not (member (transform-when transform)
                        (if *byte-compiling*
@@ -1024,8 +1037,7 @@
        (careful-call fun args call "constant folding")
       (if (not win)
        (setf (combination-kind call) :error)
-       (let ((dummies (loop repeat (length args)
-                            collect (gensym))))
+       (let ((dummies (make-gensym-list (length args))))
          (transform-call
           call
           `(lambda ,dummies
@@ -1125,8 +1137,8 @@
                         cont-atype
                         (continuation-asserted-type arg))
                        *empty-type*))
-              (eq (lexenv-cookie (node-lexenv dest))
-                  (lexenv-cookie (node-lexenv (continuation-dest arg)))))
+              (eq (lexenv-policy (node-lexenv dest))
+                  (lexenv-policy (node-lexenv (continuation-dest arg)))))
       (assert (member (continuation-kind arg)
                      '(:block-start :deleted-block-start :inside-block)))
       (assert-continuation-type arg cont-atype)
@@ -1391,12 +1403,13 @@
            (return-from ir1-optimize-mv-call)))
 
        (let ((count (cond (total-nvals)
-                          ((and (policy node (zerop safety)) (eql min max))
+                          ((and (policy node (zerop safety))
+                                (eql min max))
                            min)
                           (t nil))))
          (when count
            (with-ir1-environment node
-             (let* ((dums (loop repeat count collect (gensym)))
+             (let* ((dums (make-gensym-list count))
                     (ignore (gensym))
                     (fun (ir1-convert-lambda
                           `(lambda (&optional ,@dums &rest ,ignore)
@@ -1500,8 +1513,7 @@
     (give-up-ir1-transform))
   (setf (node-derived-type node) *wild-type*)
   (if vals
-      (let ((dummies (loop repeat (1- (length vals))
-                      collect (gensym))))
+      (let ((dummies (make-gensym-list (length (cdr vals)))))
        `(lambda (val ,@dummies)
           (declare (ignore ,@dummies))
           val))