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