From c6e55e5626ad9f1f972702f2498d09376afb6925 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Wed, 30 Apr 2003 16:48:50 +0000
Subject: [PATCH] 	Compile-time checking of calls to FORMAT.

	* src/code/format.lisp (min/max-format-arguments-count)
	(min/max-format-args, min/max-conditional-args): New functions.

	* src/compiler/srctran.lisp (check-format-args): New function.
	(format): New transformer for simple-string format control
	and (<= speed space), checking number of args.
	(format) <transforms>: Use min/max-format-arguments-count.

	* src/code/package.lisp (unintern): Add missing args to format.

	* src/compiler/disassem.lisp (maybe-note-associated-storage-ref):
	Remove extraneous format arg.
---
 code/format.lisp             | 74 +++++++++++++++++++++++++++++++++++-
 code/package.lisp            |  7 ++--
 compiler/disassem.lisp       |  5 +--
 compiler/srctran.lisp        | 39 ++++++++++++++++---
 general-info/release-19a.txt |  1 +
 5 files changed, 113 insertions(+), 13 deletions(-)

diff --git a/code/format.lisp b/code/format.lisp
index 238f543bb..d3855afe0 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.47 2003/01/23 21:05:33 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.48 2003/04/30 16:48:50 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2440,3 +2440,75 @@
                  (subseq name (1+ first-colon)))
                 (t name))
               package))))
+
+
+;;;; Compile-time checking of format arguments and control string
+
+;;;
+;;; Return the min/max numbers of arguments required for a call to
+;;; FORMAT with control string FORMAT-STRING, null if we can't tell,
+;;; or a string with an error message if parsing the control string
+;;; causes a FORMAT-ERROR.
+;;;
+;;; This is called from FORMAT deftransforms.
+;;;
+(defun min/max-format-arguments-count (string)
+  (handler-case
+      (catch 'give-up
+	;; For the side effect of validating the control string.
+	(%formatter string)
+	(%min/max-format-args (tokenize-control-string string)))
+    (format-error (e)
+      (format nil "~a" e))))
+
+(defun %min/max-format-args (directives)
+  (let ((min-req 0) (max-req 0))
+    (flet ((incf-both (&optional (n 1))
+	     (incf min-req n)
+	     (incf max-req n)))
+      (loop
+	 (let ((dir (pop directives)))
+	   (when (null dir)
+	     (return (values min-req max-req)))
+	   (when (format-directive-p dir)
+	     (incf-both (count :arg (format-directive-params dir) :key #'cdr))
+	     (let ((c (format-directive-character dir)))
+	       (cond ((find c "ABCDEFGORSWX$/")
+		      (incf-both))
+		     ((char= c #\P)
+		      (unless (format-directive-colonp dir)
+			(incf-both)))
+		     ((or (find c "IT%&|_<>();") (char= c #\newline)))
+		     ((char= c #\[)
+		      (multiple-value-bind (min max remaining)
+			  (%min/max-conditional-args dir directives)
+			(setq directives remaining)
+			(incf min-req min)
+			(incf max-req max)))
+		     (t (throw 'give-up nil))))))))))
+
+;;;
+;;; ANSI: if arg is out of range, no clause is selected.  That means
+;;; the minimum number of args required for the interior of ~[~] is
+;;; always zero.
+;;;
+(defun %min/max-conditional-args (conditional directives)
+  (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 (%min/max-format-args s))))
+	  (min-req 1)
+	  max-req)
+      (cond ((format-directive-atsignp conditional)
+	     (setq max-req (max 1 sub-max)))
+	    ((loop for p in (format-directive-params conditional)
+		   thereis (or (integerp (cdr p))
+			       (memq (cdr p) '(:remaining :arg))))
+	     (setq min-req 0)
+	     (setq max-req sub-max))
+	    (t
+	     (setq max-req (1+ sub-max))))
+      (values min-req max-req remaining))))
+
+
diff --git a/code/package.lisp b/code/package.lisp
index 9f26de0bc..2734b2cd6 100644
--- a/code/package.lisp
+++ b/code/package.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.63 2003/04/19 20:52:42 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.64 2003/04/30 16:48:50 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1280,9 +1280,10 @@
 	   (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)))))))
diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp
index 5fc7e3229..b089b1815 100644
--- a/compiler/disassem.lisp
+++ b/compiler/disassem.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.38 2003/04/27 14:00:19 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.39 2003/04/30 16:48:50 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3737,8 +3737,7 @@ symbol object that we know about.")
 			assoc-with
 			(di:debug-variable-symbol
 			 (aref (dstate-debug-variables dstate)
-			       storage-location))
-		       stream))
+			       storage-location))))
 	    dstate)
       t)))
 
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 815da9bda..27516729c 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.117 2003/04/27 14:52:27 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.118 2003/04/30 16:48:49 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3329,15 +3329,41 @@
 ;;; Furthermore, if the destination is either a stream 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)
+  (multiple-value-bind (min-args max-args)
+      (format::min/max-format-arguments-count string)
+    (when min-args
+      (let ((nargs (length args)))
+	(cond ((stringp min-args)
+	       (compiler-warning "~a" min-args))
+	      ((< nargs min-args)
+	       (compiler-warning
+		"Too few args (~d) to FORMAT, need at least ~d"
+		nargs min-args))
+	      ((> nargs max-args)
+	       (compiler-warning
+		"Too many args (~d) to FORMAT, wants at most ~d"
+		nargs max-args)))))))
+
 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
 		      :policy (> speed space))
   (unless (constant-continuation-p control)
     (give-up "Control string is not a constant."))
-  (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
-    `(lambda (dest control ,@arg-names)
-       (declare (ignore control))
-       (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+  (let ((string (continuation-value control)))
+    (check-format-args string args)
+    (let ((arg-names (mapcar (lambda (x) (declare (ignore x)) (gensym)) args)))
+      `(lambda (dest control ,@arg-names)
+	 (declare (ignore control))
+	 (format dest (formatter ,string) ,@arg-names)))))
+
+(deftransform format ((dest control &rest args) (t simple-string &rest t) *
+		      :policy (<= speed space))
+  (when (constant-continuation-p control)
+    (let ((string (continuation-value control)))
+      (check-format-args string args)
+      (give-up))))
+
 ;;;
 (deftransform format ((stream control &rest args) (stream function &rest t) *
 		      :policy (> speed space))
@@ -3353,3 +3379,4 @@
        (declare (ignore tee))
        (funcall control *standard-output* ,@arg-names)
        nil)))
+
diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index 0502b017f..c5c1691b2 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -28,6 +28,7 @@ New in this release:
      - Weak hash tables have been added for x86 systems.
      - Local functions are now named (FLET <name> ...) or 
        (LABELS <name> ...).
+     - Compiler checking control string and number of args to FORMAT.
 
   * Numerous ANSI compliance fixes:
      - Many bugs in CMUCL's type system detected by Paul Dietz'
-- 
GitLab