From b953c186cfe68e48801cb54715da0120c9580888 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 14 Aug 2003 17:16:11 +0000 Subject: [PATCH] 0.8.2.28: Extend FORMAT string checking to ERROR, CERROR and WARN (and many internal functions too) ... correct the surprising number of bugs that this reveals; ... since one of said bugs was the *INTEXP-MAX-EXPONENT* one, default this to NIL and make the error non-continuable. --- NEWS | 3 +- src/code/bignum.lisp | 2 +- src/code/cross-type.lisp | 2 +- src/code/irrat.lisp | 17 +++------ src/code/target-package.lisp | 3 +- src/compiler/assem.lisp | 2 +- src/compiler/fndb.lisp | 7 ++++ src/compiler/generic/core.lisp | 2 +- src/compiler/ir1util.lisp | 2 +- src/compiler/meta-vmdef.lisp | 4 +- src/compiler/srctran.lisp | 80 ++++++++++++++++++++++++++++++++++++---- src/compiler/x86/call.lisp | 5 ++- src/pcl/braid.lisp | 3 +- version.lisp-expr | 2 +- 14 files changed, 103 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index d43a6a3..b156efd 100644 --- a/NEWS +++ b/NEWS @@ -1945,7 +1945,8 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: 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) + constant format strings in FORMAT, and where appropriate in ERROR, + CERROR and WARN. (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/src/code/bignum.lisp b/src/code/bignum.lisp index 719f369..f7f7e5d 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -755,7 +755,7 @@ ;; take up about the same space as corresponding fixnums, there ;; should be no way that we fall through to this case: any shift ;; right by a bignum should give zero. But let's check anyway: - (t (error "bignum overflow: can't shift right by ~S"))))) + (t (error "bignum overflow: can't shift right by ~S" count))))) (defun bignum-ashift-right-digits (bignum digits) (declare (type bignum-type bignum) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 557f6db..e44501f 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -86,7 +86,7 @@ '(array character list symbol)) raw-result) (t - (error "can't handle TYPE-OF ~S in cross-compilation"))))) + (error "can't handle TYPE-OF ~S in cross-compilation" object))))) ;;; Is SYMBOL in the CL package? Note that we're testing this on the ;;; cross-compilation host, which could do things any old way. In diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 771795a..7fce068 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -83,10 +83,8 @@ ;;; INTEXP -- Handle the rational base, integer power case. -;;; FIXME: As long as the system dies on stack overflow or memory -;;; exhaustion, it seems reasonable to have this, but its default -;;; should be NIL, and when it's NIL, anything should be accepted. -(defparameter *intexp-maximum-exponent* 10000) +(declaim (type (or integer null) *intexp-maximum-exponent*)) +(defparameter *intexp-maximum-exponent* nil) ;;; This function precisely calculates base raised to an integral ;;; power. It separates the cases by the sign of power, for efficiency @@ -94,13 +92,10 @@ ;;; a positive integer. Values of power are calculated as positive ;;; integers, and inverted if negative. (defun intexp (base power) - (when (> (abs power) *intexp-maximum-exponent*) - ;; FIXME: should be ordinary error, not CERROR. (Once we set the - ;; default for the variable to NIL, the un-continuable error will - ;; be less obnoxious.) - (cerror "Continue with calculation." - "The absolute value of ~S exceeds ~S." - power '*intexp-maximum-exponent* base power)) + (when (and *intexp-maximum-exponent* + (> (abs power) *intexp-maximum-exponent*)) + (error "The absolute value of ~S exceeds ~S." + power '*intexp-maximum-exponent*)) (cond ((minusp power) (/ (intexp base (- power)))) ((eql base 2) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index ad9dc71..5caa525 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -818,7 +818,8 @@ (when cset (cerror "Unintern the conflicting symbols in the ~2*~A package." - "Use'ing package ~A results in name conflicts for these symbols:~%~S" + "Using package ~A results in name conflicts for these symbols:~%~ + ~S" (package-%name pkg) cset (package-%name package)) (dolist (s cset) (moby-unintern s package)))) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 778eb41..b668c11 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -768,7 +768,7 @@ p ;; the branch has two dependents and one of them dpends on (declare (type segment segment) (type annotation note)) (when (annotation-posn note) - (error "attempt to emit ~S a second time")) + (error "attempt to emit ~S a second time" note)) (setf (annotation-posn note) (segment-current-posn segment)) (setf (annotation-index note) (segment-current-index segment)) (let ((last (segment-last-annotation segment)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 8d6a0d7..ca85fa7 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1426,3 +1426,10 @@ (defknown policy-quality (policy symbol) policy-quality (flushable)) + +(defknown (compiler-abort compiler-error) (string &rest t) nil ()) +(defknown (compiler-warn compiler-style-warn) (string &rest t) (values) ()) +(defknown (compiler-notify maybe-compiler-notify) ((or string symbol) &rest t) + (values) + ()) +(defknown style-warn (string &rest t) null ()) diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index 329f5a2..4fa0787 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -58,7 +58,7 @@ (:foreign (aver (stringp name)) (or (foreign-symbol-address-as-integer name) - (error "unknown foreign symbol: ~S"))) + (error "unknown foreign symbol: ~S" name))) #!+x86 (:code-object (aver (null name)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 429c7ae..75c9723 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -500,7 +500,7 @@ ((continuation-block cont) (block-home-lambda-or-null (continuation-block cont))) (t - (bug "confused about home lambda for ~S")))) + (bug "confused about home lambda for ~S" cont)))) ;;; Return the LAMBDA that is CONT's home. (declaim (ftype (sfunction (continuation) clambda) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index f306dea..25326ad 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -754,13 +754,13 @@ (rassoc name (funs))))) (unless name (error "no move function defined to ~:[save~;load~] SC ~S ~ - with ~S ~:[to~;from~] from SC ~S" + ~:[to~;from~] from SC ~S" load-p sc-name load-p (sc-name alt))) (cond (found (unless (eq (cdr found) name) (error "can't tell whether to ~:[save~;load~]~@ - or ~S when operand is in SC ~S" + with ~S or ~S when operand is in SC ~S" load-p name (cdr found) (sc-name alt))) (pushnew alt (car found))) (t diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 89747f7..a05a91a 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3254,7 +3254,19 @@ ;;;; 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) +;;; for compile-time argument count checking. +;;; +;;; FIXME I: this is currently called from DEFTRANSFORMs, the vast +;;; majority of which are not going to transform the code, but instead +;;; are going to GIVE-UP-IR1-TRANSFORM unconditionally. It would be +;;; nice to make this explicit, maybe by implementing a new +;;; "optimizer" (say, DEFOPTIMIZER CONSISTENCY-CHECK). +;;; +;;; FIXME II: In some cases, type information could be correlated; for +;;; instance, ~{ ... ~} requires a list argument, so if the +;;; continuation-type of a corresponding argument is known and does +;;; not intersect the list type, a warning could be signalled. +(defun check-format-args (string args fun) (declare (type string string)) (unless (typep string 'simple-string) (setq string (coerce string 'simple-string))) @@ -3266,9 +3278,9 @@ (let ((nargs (length args))) (cond ((< nargs min) - (compiler-warn "Too few arguments (~D) to FORMAT ~S: ~ + (compiler-warn "Too few arguments (~D) to ~S ~S: ~ requires at least ~D." - nargs string min)) + nargs fun string min)) ((> nargs max) (;; to get warned about probably bogus code at ;; cross-compile time. @@ -3276,8 +3288,8 @@ ;; 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))))))) + "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) @@ -3286,13 +3298,13 @@ ((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) + (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)) + (check-format-args (continuation-value control) args 'format)) (give-up-ir1-transform)))) (deftransform format ((stream control &rest args) (stream function &rest t) * @@ -3310,6 +3322,60 @@ (funcall control *standard-output* ,@arg-names) nil))) +(macrolet + ((def (name) + `(deftransform ,name + ((control &rest args) (simple-string &rest t) *) + (when (constant-continuation-p control) + (check-format-args (continuation-value control) args ',name)) + (give-up-ir1-transform)))) + (def error) + (def warn) + #+sb-xc-host ; Only we should be using these + (progn + (def style-warn) + (def compiler-abort) + (def compiler-error) + (def compiler-warn) + (def compiler-style-warn) + (def compiler-notify) + (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)) + ((> 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)))))))) + (give-up-ir1-transform)) + (defoptimizer (coerce derive-type) ((value type)) (cond ((constant-continuation-p type) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 5a8a202..fa1c56d 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -645,8 +645,9 @@ (inst pop ebp-tn)) (t - (cerror "Continue any-way" - "VOP return-local doesn't work if old-fp (in slot %s) is not in slot 0" + (cerror "Continue anyway" + "VOP return-local doesn't work if old-fp (in slot ~ + ~S) is not in slot 0" (tn-offset old-fp))))) ((any-reg descriptor-reg) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 1071e78..066e6c4 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -194,7 +194,8 @@ class) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) - (error "Slot allocation ~S is not supported in bootstrap."))) + (error "Slot allocation ~S is not supported in bootstrap." + (getf slot :allocation)))) (when (typep wrapper 'wrapper) (setf (wrapper-instance-slots-layout wrapper) diff --git a/version.lisp-expr b/version.lisp-expr index b1fa40d..8513e96 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.27" +"0.8.2.28" -- 1.7.10.4