From 9cd69ef4f515e7917da3cc69ed228d520b6bcd29 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 7 Aug 2003 09:32:07 +0000 Subject: [PATCH] 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 | 2 + package-data-list.lisp-expr | 3 +- src/code/late-format.lisp | 112 +++++++++++++++++++++++++++++++++++++ src/code/target-package.lisp | 4 +- src/compiler/srctran.lisp | 46 ++++++++++++--- src/compiler/target-disassem.lisp | 3 +- version.lisp-expr | 2 +- 7 files changed, 159 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index 1b66f63..3f784b0 100644 --- a/NEWS +++ b/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) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 726eda7..6746658 100644 --- a/package-data-list.lisp-expr +++ b/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" diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 3d821ad..77597af 100644 --- a/src/code/late-format.lisp +++ b/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))))))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 05c80ad..ad9dc71 100644 --- a/src/code/target-package.lisp +++ b/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))))))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index f0df2a0..ab4fc17 100644 --- a/src/compiler/srctran.lisp +++ b/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)) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 191636c..4b73b0b 100644 --- a/src/compiler/target-disassem.lisp +++ b/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))) diff --git a/version.lisp-expr b/version.lisp-expr index 962c41d..c86a176 100644 --- 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.18" +"0.8.2.19" -- 1.7.10.4