0.8.2.19:

	Slightly-updated version of first cut at FORMAT compile-time
	argument checking (CSR sbcl-devel 2003-08-06)
	... only argument count for now.

NEWS

@@ -1944,6 +1944,8 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2:
   * Compiler code deletion notes now signal a condition of type
     SB-EXT:CODE-DELETION-NOTE (a subtype of SB-EXT:COMPILER-NOTE) with
     an associated MUFFLE-WARNING restart.
+  * The compiler now performs limited argument count validation of
+    constant format strings in FORMAT.  (thanks to Gerd Moellmann)
   * bug fix: WITH-OUTPUT-TO-STRING (and MAKE-STRING-OUTPUT-STREAM) now
     accept and act upon their :ELEMENT-TYPE keyword argument.
     (reported by Edi Weitz)

package-data-list.lisp-expr

@@ -646,7 +646,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
  #s(sb-cold:package-data
     :name "SB!FORMAT"
     :doc "private: implementation of FORMAT and friends"
-    :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL"))
+    :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
+    :export ("%COMPILER-WALK-FORMAT-STRING" "FORMAT-ERROR"))
 
  #s(sb-cold:package-data
     :name "SB!GRAY"

src/code/late-format.lisp

@@ -1203,3 +1203,115 @@
 		 (subseq name (1+ first-colon)))
 		(t name))
 	      package))))
+
+;;; compile-time checking for argument mismatch.  This code is
+;;; inspired by that of Gerd Moellmann, and comes decorated with
+;;; FIXMEs:
+(defun %compiler-walk-format-string (string args)
+  (declare (type simple-string string))
+  (let ((*default-format-error-control-string* string))
+    (macrolet ((incf-both (&optional (increment 1))
+		 `(progn
+		   (incf min ,increment)
+		   (incf max ,increment)))
+	       (walk-complex-directive (function)
+		 `(multiple-value-bind (min-inc max-inc remaining)
+		   (,function directive directives args)
+		   (incf min min-inc)
+		   (incf max max-inc)
+		   (setq directives remaining))))
+      ;; FIXME: these functions take a list of arguments as well as
+      ;; the directive stream.  This is to enable possibly some
+      ;; limited type checking on FORMAT's arguments, as well as
+      ;; simple argument count mismatch checking: when the minimum and
+      ;; maximum argument counts are the same at a given point, we
+      ;; know which argument is going to be used for a given
+      ;; directive, and some (annotated below) require arguments of
+      ;; particular types.
+      (labels
+	  ((walk-justification (justification directives args)
+	     (declare (ignore args))
+	     (let ((*default-format-error-offset*
+		    (1- (format-directive-end justification))))
+	       (multiple-value-bind (segments first-semi close remaining)
+		   (parse-format-justification directives)
+		 (declare (ignore segments first-semi))
+		 (cond
+		   ((not (format-directive-colonp close))
+		    (values 0 0 directives))
+		   ((format-directive-atsignp justification)
+		    (values 0 sb!xc:call-arguments-limit directives))
+		   ;; FIXME: here we could assert that the
+		   ;; corresponding argument was a list.
+		   (t (values 1 1 remaining))))))
+	   (walk-conditional (conditional directives args)
+	     (declare (ignore args))
+	     (let ((*default-format-error-offset*
+		    (1- (format-directive-end conditional))))
+	       (multiple-value-bind (sublists last-semi-with-colon-p remaining)
+		   (parse-conditional-directive directives)
+		 (declare (ignore last-semi-with-colon-p))
+		 (let ((sub-max (loop for s in sublists
+				      maximize (nth-value 1 (walk-directive-list s args)))))
+		   (cond
+		     ((format-directive-atsignp conditional)
+		      (values 1 (max 1 sub-max) remaining))
+		     ((loop for p in (format-directive-params conditional)
+			    thereis (or (integerp (cdr p))
+					(memq (cdr p) '(:remaining :arg))))
+		      (values 0 sub-max remaining))
+		     ;; FIXME: if not COLONP, then the next argument
+		     ;; must be a number.
+		     (t (values 1 (1+ sub-max) remaining)))))))
+	   (walk-iteration (iteration directives args)
+	     (declare (ignore args))
+	     (let ((*default-format-error-offset*
+		    (1- (format-directive-end iteration))))
+	       (let* ((close (find-directive directives #\} nil))
+		      (posn (position close directives))
+		      (remaining (nthcdr (1+ posn) directives)))
+		 ;; FIXME: if POSN is zero, the next argument must be
+		 ;; a format control (either a function or a string).
+		 (if (format-directive-atsignp iteration)
+		     (values (if (zerop posn) 1 0)
+			     sb!xc:call-arguments-limit
+			     remaining)
+		     ;; FIXME: the argument corresponding to this
+		     ;; directive must be a list.
+		     (let ((nreq (if (zerop posn) 2 1)))
+		       (values nreq nreq remaining))))))
+	   (walk-directive-list (directives args)
+	     (let ((min 0) (max 0))
+	       (loop
+		(let ((directive (pop directives)))
+		  (when (null directive)
+		    (return (values min (min max sb!xc:call-arguments-limit))))
+		  (when (format-directive-p directive)
+		    (incf-both (count :arg (format-directive-params directive)
+				      :key #'cdr))
+		    (let ((c (format-directive-character directive)))
+		      (cond
+			((find c "ABCDEFGORSWX$/")
+			 (incf-both))
+			((char= c #\P)
+			 (unless (format-directive-colonp directive)
+			   (incf-both)))
+			((or (find c "IT%&|_();>") (char= c #\Newline)))
+			((char= c #\<)
+			 (walk-complex-directive walk-justification))
+			((char= c #\[)
+			 (walk-complex-directive walk-conditional))
+			((char= c #\{)
+			 (walk-complex-directive walk-iteration))
+			((char= c #\?)
+			 ;; FIXME: the argument corresponding to this
+			 ;; directive must be a format control.
+			 (cond
+			   ((format-directive-atsignp directive)
+			    (incf min)
+			    (setq max sb!xc:call-arguments-limit))
+			   (t (incf-both 2))))
+			(t (throw 'give-up-format-string-walk nil))))))))))
+	(catch 'give-up-format-string-walk
+	  (let ((directives (tokenize-control-string string)))
+	    (walk-directive-list directives args)))))))

src/code/target-package.lisp

@@ -540,9 +540,9 @@
 	   (let ((sym (read *query-io*)))
 	     (cond
 	      ((not (symbolp sym))
-	       (format *query-io* "~S is not a symbol."))
+	       (format *query-io* "~S is not a symbol." sym))
 	      ((not (member sym cset))
-	       (format *query-io* "~S is not one of the conflicting symbols."))
+	       (format *query-io* "~S is not one of the conflicting symbols." sym))
 	      (t
 	       (shadowing-import sym package)
 	       (return-from unintern t)))))))

src/compiler/srctran.lisp

@@ -3191,14 +3191,46 @@
 ;;;; or T and the control string is a function (i.e. FORMATTER), then
 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
 
+(defun check-format-args (string args)
+  (declare (type string string))
+  (unless (typep string 'simple-string)
+    (setq string (coerce string 'simple-string)))
+  (multiple-value-bind (min max)
+      (handler-case (sb!format:%compiler-walk-format-string string args)
+	(sb!format:format-error (c)
+	  (compiler-warn "~A" c)))
+    (when min
+      (let ((nargs (length args)))
+	(cond
+	  ((< nargs min)
+	   (compiler-warn "Too few arguments (~D) to FORMAT ~S: ~
+                           requires at least ~D."
+			  nargs string min))
+	  ((> nargs max)
+	   (;; 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 FORMAT ~S: uses at most ~D."
+	    nargs string max)))))))
+
 (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))))
+		      :node node)
+
+  (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)
+     (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))
+       (give-up-ir1-transform))))
 
 (deftransform format ((stream control &rest args) (stream function &rest t) *
 		      :policy (> speed space))

src/compiler/target-disassem.lisp

@@ -1956,8 +1956,7 @@
 		      assoc-with
 		      (sb!di:debug-var-symbol
 		       (aref (dstate-debug-vars dstate)
-			     storage-location))
-		      stream))
+			     storage-location))))
 	    dstate)
       t)))
 

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.18"
+"0.8.2.19"