X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fsrctran.lisp;h=fb6f0f765e890259d4cc72ccef13062fe1fdbb69;hb=b42068e9080417a073dcb709cdd2e0315599b3df;hp=c59ab7c868b698e325bb0db1330fc37d2eee13b4;hpb=77af6d16968262049d6dadfb5521af7a8a7c6868;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c59ab7c..fb6f0f7 100644
--- 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
@@ -3678,5 +3677,5 @@
       (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
     (format t "/MESSAGE=~S~%" (continuation-value message))
     (give-up-ir1-transform "not a real transform"))
-  (defun /report-continuation (&rest rest)
-    (declare (ignore rest))))
+  (defun /report-continuation (x message)
+    (declare (ignore x message))))