0.8.2.42:

	FORMAT string deftransforms can give spurious optimization notes
	on e.g. (COMPILE NIL '(LAMBDA (X) (ERROR X))); implement
	checking of constant format strings via DEFOPTIMIZER OPTIMIZER
	instead.
	... also add rudimentary test of warning functionality

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c59ab7c..2f56497 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3314,21 +3314,20 @@
            "Too many arguments (~D) to ~S ~S: uses at most ~D."
            nargs fun string max)))))))
 
-(deftransform format ((dest control &rest args) (t simple-string &rest t) *
-                     :node node)
+(defoptimizer (format optimizer) ((dest control &rest args))
+  (when (constant-continuation-p control)
+    (let ((x (continuation-value control)))
+      (when (stringp x)
+       (check-format-args x args 'format)))))
 
-  (cond
-    ((policy node (> speed space))
-     (unless (constant-continuation-p control)
-       (give-up-ir1-transform "The control string is not a constant."))
-     (check-format-args (continuation-value control) args 'format)
-     (let ((arg-names (make-gensym-list (length args))))
-       `(lambda (dest control ,@arg-names)
-        (declare (ignore control))
-        (format dest (formatter ,(continuation-value control)) ,@arg-names))))
-    (t (when (constant-continuation-p control)
-        (check-format-args (continuation-value control) args 'format))
-       (give-up-ir1-transform))))
+(deftransform format ((dest control &rest args) (t simple-string &rest t) *
+                     :policy (> speed space))
+  (unless (constant-continuation-p control)
+    (give-up-ir1-transform "The control string is not a constant."))
+  (let ((arg-names (make-gensym-list (length args))))
+    `(lambda (dest control ,@arg-names)
+       (declare (ignore control))
+       (format dest (formatter ,(continuation-value control)) ,@arg-names))))
 
 (deftransform format ((stream control &rest args) (stream function &rest t) *
                      :policy (> speed space))
@@ -3347,11 +3346,11 @@
 
 (macrolet
     ((def (name)
-        `(deftransform ,name
-             ((control &rest args) (simple-string &rest t) *)
+        `(defoptimizer (,name optimizer) ((control &rest args))
            (when (constant-continuation-p control)
-             (check-format-args (continuation-value control) args ',name))
-          (give-up-ir1-transform))))
+             (let ((x (continuation-value control)))
+               (when (stringp x)
+                 (check-format-args x args ',name)))))))
   (def error)
   (def warn)
   #+sb-xc-host ; Only we should be using these
@@ -3365,39 +3364,39 @@
     (def maybe-compiler-notify)
     (def bug)))
 
-(deftransform cerror ((report control &rest args)
-                     (simple-string simple-string &rest t) *)
-  (unless (and (constant-continuation-p control)
-              (constant-continuation-p report))
-    (give-up-ir1-transform))
-  (multiple-value-bind (min1 max1)
-      (handler-case (sb!format:%compiler-walk-format-string
-                    (continuation-value control) args)
-       (sb!format:format-error (c)
-         (compiler-warn "~A" c)))
-    (when min1
-      (multiple-value-bind (min2 max2)
-         (handler-case (sb!format:%compiler-walk-format-string
-                        (continuation-value report) args)
-           (sb!format:format-error (c)
-             (compiler-warn "~A" c)))
-       (when min2
-         (let ((nargs (length args)))
-           (cond
-             ((< nargs (min min1 min2))
-              (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~
-                               requires at least ~D."
-                             nargs 'cerror report control (min min1 min2)))
-             ((> nargs (max max1 max2))
-              (;; to get warned about probably bogus code at
-               ;; cross-compile time.
-               #+sb-xc-host compiler-warn
-               ;; ANSI saith that too many arguments doesn't cause a
-               ;; run-time error.
-               #-sb-xc-host compiler-style-warn
-               "Too many arguments (~D) to ~S ~S ~S: uses at most ~D."
-               nargs 'cerror report control (max max1 max2)))))))))
-  (give-up-ir1-transform))
+(defoptimizer (cerror optimizer) ((report control &rest args))
+  (when (and (constant-continuation-p control)
+            (constant-continuation-p report))
+    (let ((x (continuation-value control))
+         (y (continuation-value report)))
+      (when (and (stringp x) (stringp y))
+       (multiple-value-bind (min1 max1)
+           (handler-case
+               (sb!format:%compiler-walk-format-string x args)
+             (sb!format:format-error (c)
+               (compiler-warn "~A" c)))
+         (when min1
+           (multiple-value-bind (min2 max2)
+               (handler-case
+                   (sb!format:%compiler-walk-format-string y args)
+                 (sb!format:format-error (c)
+                   (compiler-warn "~A" c)))
+             (when min2
+               (let ((nargs (length args)))
+                 (cond
+                   ((< nargs (min min1 min2))
+                    (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~
+                                     requires at least ~D."
+                                   nargs 'cerror y x (min min1 min2)))
+                   ((> nargs (max max1 max2))
+                    (;; to get warned about probably bogus code at
+                     ;; cross-compile time.
+                     #+sb-xc-host compiler-warn
+                     ;; ANSI saith that too many arguments doesn't cause a
+                     ;; run-time error.
+                     #-sb-xc-host compiler-style-warn
+                     "Too many arguments (~D) to ~S ~S ~S: uses at most ~D."
+                     nargs 'cerror y x (max max1 max2)))))))))))))
 
 (defoptimizer (coerce derive-type) ((value type))
   (cond

diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 149ab19..65d0341 100644 (file)
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -97,6 +97,19 @@ EOF
     fi
 }
 
+fail_on_compiler_note ()
+{
+    $SBCL <<EOF
+        (handler-bind ((sb-ext:compiler-note #'error))
+          (compile-file "$1")
+          (sb-ext:quit :unix-status 52))
+EOF
+    if [ $? != 52]; then
+        echo compiler-note $1 test failed: $?
+        exit 1
+    fi
+}
+
 base_tmpfilename="compiler-test-$$-tmp"
 tmpfilename="$base_tmpfilename.lisp"
 compiled_tmpfilename="$base_tmpfilename.fasl"
@@ -196,6 +209,24 @@ cat > $tmpfilename <<EOF
 EOF
 expect_failed_compile $tmpfilename
 
+# ERROR wants to check its format string for sanity...
+cat > $tmpfilename <<EOF
+    (in-package :cl-user)
+    (defun foo (x)
+      (when x
+        (error "~S")))
+EOF
+expect_failed_compile $tmpfilename
+
+# ... but it (ERROR) shouldn't complain about being unable to optimize
+# when it's uncertain about its argument's type
+cat > $tmpfilename <<EOF
+    (in-package :cl-user)
+    (defun foo (x)
+      (error x))
+EOF
+fail_on_compiler_note $tmpfilename
+
 rm $tmpfilename
 rm $compiled_tmpfilename
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 6ebf795..77ca046 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.2.41"
+"0.8.2.42"