From bfa4310e41dcd011ca9d139f29be1c5757b41378 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 27 May 2004 16:06:40 +0000 Subject: [PATCH] 0.8.10.57: First cut at REFERENCE-CONDITIONs, and beginnings of condition hierarchy. Please feel free to join in the fun (see TODO). --- NEWS | 11 +++++ TODO | 18 +++++-- package-data-list.lisp-expr | 6 +++ src/code/condition.lisp | 98 +++++++++++++++++++++++++++++++++----- src/code/defpackage.lisp | 15 +++--- src/compiler/array-tran.lisp | 14 ++++-- src/compiler/checkgen.lisp | 16 +++++-- src/compiler/ctype.lisp | 7 +-- src/compiler/ir1opt.lisp | 2 +- src/compiler/ir1report.lisp | 25 +++------- src/compiler/ir1tran-lambda.lisp | 4 +- src/compiler/ir1tran.lisp | 45 +++++++++-------- src/compiler/ir1util.lisp | 4 +- src/compiler/locall.lisp | 40 +++++----------- tests/type.impure.lisp | 35 +++++++------- version.lisp-expr | 2 +- 16 files changed, 218 insertions(+), 124 deletions(-) diff --git a/NEWS b/NEWS index f311ac1..dbb5997 100644 --- a/NEWS +++ b/NEWS @@ -2398,11 +2398,22 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9: to Bruno Haible) changes in sbcl-0.8.11 relative to sbcl-0.8.10: + * minor incompatible change: the sb-grovel contrib now treats C + structures as alien (in the sense of SB-ALIEN) objects rather than + as undistinguished (simple-array (unsigned-byte 8) (*))s. This + has implications for memory management of client code + (sb-grovel-returned objects must now be manually managed) and for + type safety (alien objects now have full types). * new feature: the SB-EXT:MUFFLE-CONDITIONS declaration should be used to control emission of compiler diagnostics, rather than the SB-EXT:INHIBIT-WARNINGS OPTIMIZE quality. See the manual for documentation on this feature. The SB-EXT:INHIBIT-WARNINGS quality should be considered deprecated. + * (not quite a new documentable feature, but worth considering in + the light of the new SB-EXT:MUFFLE-CONDITIONS declaration): the + beginnings of a semantically meaningful condition hierarchy is + under development, for use in SB-EXT:MUFFLE-CONDITIONS and by + IDEs. * fixed bug: DEFCLASS slot definitions with identical :READER and :WRITER names now signal a reasonable error. (reported by Thomas Burdick) diff --git a/TODO b/TODO index 28e5af2..30ee13d 100644 --- a/TODO +++ b/TODO @@ -57,12 +57,24 @@ for early 0.8.x: * Make the system sources understandable to the system, so that searching for sources doesn't error out quite so often (e.g. in error handlers) - ** provided a location-independent way of referring to source - files in the target image, maybe a SYS: logical - pathname, and made the build system respect this. ** provided a suitable readtable for reading in the source files when necessary, and a mechanism for activating this readtable rather than the standard one. +* Some work on conditions emitted by the system + ** eliminated COMPILER-WARN and COMPILER-STYLE-WARN, which + were simply limited versions of WARN and STYLE-WARN. + ** eliminated use of INHIBIT-WARNINGS by code emitted by the + system from user code. + ** caused use of INHIBIT-WARNINGS to signal a STYLE-WARNING. + ** eliminated use of INHIBIT-WARNINGS within the system + ** deprecated INHIBIT-WARNINGS, causing its use to signal a + full WARNING. + ** began work on developing a class hierarchy of conditions + along semantic lines. + ** annotated conditions emitted by the system to have + references to documentation where applicable, so that + users can easily find an explanation for the + conditions they're seeing. ======================================================================= for 0.9: diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 833c2b2..9702f6d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -799,7 +799,13 @@ retained, possibly temporariliy, because it might be used internally." ;; ..and CONDITIONs.. "BUG" "UNSUPPORTED-OPERATOR" + "REFERENCE-CONDITION" "REFERENCE-CONDITION-REFERENCES" + "*PRINT-CONDITION-REFERENCES*" + "DUPLICATE-DEFINITION" "DUPLICATE-DEFINITION-NAME" + "PACKAGE-AT-VARIANCE" "ARRAY-INITIAL-ELEMENT-MISMATCH" + "TYPE-WARNING" "LOCAL-ARGUMENT-MISMATCH" + ;; ..and DEFTYPEs.. "INDEX" "LOAD/STORE-INDEX" "SIGNED-BYTE-WITH-A-BITE-OUT" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 699bb23..3765b9b 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -840,19 +840,7 @@ (reader-error-format-arguments condition) (reader-impossible-number-error-error condition)))))) -(define-condition sb!ext::timeout (serious-condition) ()) - -(define-condition defconstant-uneql (error) - ((name :initarg :name :reader defconstant-uneql-name) - (old-value :initarg :old-value :reader defconstant-uneql-old-value) - (new-value :initarg :new-value :reader defconstant-uneql-new-value)) - (:report - (lambda (condition stream) - (format stream - "~@" - (defconstant-uneql-name condition) - (defconstant-uneql-old-value condition) - (defconstant-uneql-new-value condition))))) +(define-condition timeout (serious-condition) ()) ;;;; special SBCL extension conditions @@ -917,6 +905,90 @@ "unsupported on this platform (OS, CPU, whatever): ~S" (cell-error-name condition))))) +;;; (:ansi-cl :function remove) +;;; (:ansi-cl :section (a b c)) +;;; (:ansi-cl :glossary "similar") +;;; +;;; (:sbcl :node "...") +;;; +;;; FIXME: this is not the right place for this. +(defun print-reference (reference stream) + (ecase (car reference) + (:ansi-cl + (format stream "The ANSI Standard") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:function (format stream "Function ~S" data)) + (:special-operator (format stream "Special Operator ~S" data)) + (:macro (format stream "Macro ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data)) + (:glossary (format stream "Glossary Entry ~S" data))))) + (:sbcl + (format stream "The SBCL Manual") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:node (format stream "Node ~S" data))))) + ;; FIXME: other documents (e.g. AMOP, Franz documentation :-) + )) +(define-condition reference-condition () + ((references :initarg :references :reader reference-condition-references))) +(defvar *print-condition-references* t) +(def!method print-object :around ((o reference-condition) s) + (call-next-method) + (unless (or *print-escape* *print-readably*) + (when *print-condition-references* + (format s "~&See also:~%") + (pprint-logical-block (s nil :per-line-prefix " ") + (do* ((rs (reference-condition-references o) (cdr rs)) + (r (car rs) (car rs))) + ((null rs)) + (print-reference r s) + (unless (null (cdr rs)) + (terpri s))))))) + +(define-condition duplicate-definition (reference-condition warning) + ((name :initarg :name :reader duplicate-definition-name)) + (:report (lambda (c s) + (format s "~@" + (duplicate-definition-name c)))) + (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) + +(define-condition package-at-variance (reference-condition simple-warning) + () + (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) + +(define-condition defconstant-uneql (reference-condition error) + ((name :initarg :name :reader defconstant-uneql-name) + (old-value :initarg :old-value :reader defconstant-uneql-old-value) + (new-value :initarg :new-value :reader defconstant-uneql-new-value)) + (:report + (lambda (condition stream) + (format stream + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition)))) + (:default-initargs :references (list '(:ansi-cl :macro defconstant) + '(:sbcl :node "Idiosyncrasies")))) + +(define-condition array-initial-element-mismatch + (reference-condition simple-warning) + () + (:default-initargs + :references (list '(:ansi-cl :function make-array) + '(:ansi-cl :function upgraded-array-element-type)))) + +(define-condition type-warning (reference-condition simple-warning) + () + (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) + +(define-condition local-argument-mismatch (reference-condition simple-warning) + () + (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) + ;;;; restart definitions (define-condition abort-failure (control-error) () diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 2d50d0a..efb100e 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -182,8 +182,9 @@ (shadowing-import sym package) (setf old-shadows (remove sym old-shadows)))))) (when old-shadows - (warn "~A also shadows the following symbols:~% ~S" - name old-shadows))) + (warn 'package-at-variance + :format-control "~A also shadows the following symbols:~% ~S" + :format-arguments (list name old-shadows)))) ;; Handle USE. (unless (eq use :default) (let ((old-use-list (package-use-list package)) @@ -192,9 +193,9 @@ (let ((laterize (set-difference old-use-list new-use-list))) (when laterize (unuse-package laterize package) - (warn "~A used to use the following packages:~% ~S" - name - laterize))))) + (warn 'package-at-variance + :format-control "~A used to use the following packages:~% ~S" + :format-arguments (list name laterize)))))) ;; Handle IMPORT and INTERN. (dolist (sym-name interns) (intern sym-name package)) @@ -213,7 +214,9 @@ (export exports package) (let ((diff (set-difference old-exports exports))) (when diff - (warn "~A also exports the following symbols:~% ~S" name diff)))) + (warn 'package-at-variance + :format-control "~A also exports the following symbols:~% ~S" + :format-arguments (list name diff))))) ;; Handle documentation. (setf (package-doc-string package) doc-string) package)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 02cbb75..3d6448a 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -242,11 +242,15 @@ ((not (ctypep value (sb!vm:saetp-ctype saetp))) ;; this case will cause an error at runtime, so we'd ;; better WARN about it now. - (compiler-warn "~@<~S is not a ~S (which is the ~ - UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>" - value - (type-specifier (sb!vm:saetp-ctype saetp)) - eltype)) + (warn 'array-initial-element-mismatch + :format-control "~@<~S is not a ~S (which is the ~ + ~S of ~S).~@:>" + :format-arguments + (list + value + (type-specifier (sb!vm:saetp-ctype saetp)) + 'upgraded-array-element-type + eltype))) ((not (ctypep value eltype-type)) ;; this case will not cause an error at runtime, but ;; it's still worth STYLE-WARNing about. diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 8d04f94..3fd81d5 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -436,12 +436,18 @@ (leaf-source-name (elt (lambda-vars lambda) pos))))))) (cond ((and (ref-p use) (constant-p (ref-leaf use))) - (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" - what atype-spec (constant-value (ref-leaf use)))) + (warn 'type-warning + :format-control + "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" + :format-arguments + (list what atype-spec + (constant-value (ref-leaf use))))) (t - (compiler-warn - "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" - what (type-specifier dtype) atype-spec)))))))) + (warn 'type-warning + :format-control + "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" + :format-arguments + (list what (type-specifier dtype) atype-spec))))))))) (values)) ;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set, diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 33c772a..babda46 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -850,7 +850,8 @@ (let ((atype (lvar-value atype)) (dtype (lvar-value dtype))) (unless (eq atype nil) - (compiler-warn - "~@" - atype dtype)))) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list atype dtype))))) (ir2-convert-full-call node block))) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 370c5a9..b538652 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -977,7 +977,7 @@ (:aborted (setf (combination-kind node) :error) (when args - (apply #'compiler-warn args)) + (apply #'warn args)) (remhash node table) nil) (:failure diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 6828f90..ea34114 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -383,16 +383,9 @@ (style-warning 'style-warning) (warning 'warning) ((or error compiler-error) 'error)))) - (multiple-value-bind (format-string format-args) - (if (typep condition 'simple-condition) - (values (simple-condition-format-control condition) - (simple-condition-format-arguments condition)) - (values "~A" - (list (with-output-to-string (s) - (princ condition s))))) - (print-compiler-message - (format nil "caught ~S:~% ~A" what format-string) - format-args))) + (print-compiler-message + (format nil "caught ~S:~%~~@< ~~@;~~A~~:>" what) + (list (with-output-to-string (s) (princ condition s))))) (values)) ;;; The act of signalling one of these beasts must not cause WARNINGSP @@ -425,15 +418,9 @@ has written, having proved that it is unreachable.")) (muffle-warning () (return-from compiler-notify (values)))) (incf *compiler-note-count*) - (multiple-value-bind (format-string format-args) - (if (typep condition 'simple-condition) - (values (simple-condition-format-control condition) - (simple-condition-format-arguments condition)) - (values "~A" - (list (with-output-to-string (s) - (princ condition s))))) - (print-compiler-message (format nil "note: ~A" format-string) - format-args)))) + (print-compiler-message + (format nil "note: ~~A") + (list (with-output-to-string (s) (princ condition s)))))) (values)) ;;; Issue a note when we might or might not be in the compiler. diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index d1bd58f..c107a93 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -1095,9 +1095,7 @@ (aver (fasl-output-p *compile-object*)) (if (member name *fun-names-in-this-file* :test #'equal) - (compiler-warn "~@" - name) + (warn 'duplicate-definition :name name) (push name *fun-names-in-this-file*))) (become-defined-fun-name name) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 8ed61a8..37ddb42 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -624,7 +624,7 @@ ;; there's no need for us to accept ANSI's lameness when ;; processing our own code, though. #+sb-xc-host - (compiler-warn "reading an ignored variable: ~S" name))) + (warn "reading an ignored variable: ~S" name))) (reference-leaf start next result var)) (cons (aver (eq (car var) 'MACRO)) @@ -743,8 +743,8 @@ (muffle-warning-or-die))) #-(and cmu sb-xc-host) (warning (lambda (c) - (compiler-warn "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c) + (warn "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c) (muffle-warning-or-die))) (error (lambda (c) (compiler-error "~@<~A~:@_~A~@:_~A~:>" @@ -928,22 +928,29 @@ (find-free-var var-name)))) (etypecase var (leaf - (flet ((process-var (var bound-var) - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (fun-type-p type) - (fun-type-p old-type)) - type - (type-approx-intersection2 old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warn - "The type declarations ~S and ~S for ~S conflict." - (type-specifier old-type) (type-specifier type) - var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int))))))) + (flet + ((process-var (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (fun-type-p type) + (fun-type-p old-type)) + type + (type-approx-intersection2 + old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy *lexenv* (= inhibit-warnings 3)) + (warn + 'type-warning + :format-control + "The type declarations ~S and ~S for ~S conflict." + :format-arguments + (list + (type-specifier old-type) + (type-specifier type) + var-name)))) + (bound-var (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) (process-var var bound-var) (awhen (and (lambda-var-p var) (lambda-var-specvar var)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 23281cb..1f7cb2e 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1161,8 +1161,8 @@ ;; There's no reason to accept this kind of equivocation ;; when compiling our own code, though. #+sb-xc-host - (compiler-warn "The variable ~S is defined but never used." - (leaf-debug-name var))) + (warn "The variable ~S is defined but never used." + (leaf-debug-name var))) (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN (values)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index fa366db..8ebe63a 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -468,26 +468,11 @@ (cond ((= n-call-args nargs) (convert-call ref call fun)) (t - ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the - ;; Compiler" that calling a function with "the wrong number of - ;; arguments" be only a STYLE-ERROR. I think, though, that this - ;; should only apply when the number of arguments is inferred - ;; from a previous definition. If the number of arguments - ;; is DECLAIMed, surely calling with the wrong number is a - ;; real WARNING. As long as SBCL continues to use CMU CL's - ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here, - ;; but as long as we continue to use that policy, that's the - ;; not our biggest problem.:-| When we fix that policy, this - ;; should come back into compliance. (So fix that policy!) - ;; ..but.. - ;; FIXME, continued: Except that section "3.2.2.3 Semantic - ;; Constraints" says that if it's within the same file, it's - ;; wrong. And we're in locall.lisp here, so it's probably - ;; (haven't checked this..) a call to something in the same - ;; file. So maybe it deserves a full warning anyway. - (compiler-warn + (warn + 'local-argument-mismatch + :format-control "function called with ~R argument~:P, but wants exactly ~R" - n-call-args nargs) + :format-arguments (list n-call-args nargs)) (setf (basic-combination-kind call) :error))))) ;;;; &OPTIONAL, &MORE and &KEYWORD calls @@ -504,11 +489,11 @@ (max-args (optional-dispatch-max-args fun)) (call-args (length (combination-args call)))) (cond ((< call-args min-args) - ;; FIXME: See FIXME note at the previous - ;; wrong-number-of-arguments warnings in this file. - (compiler-warn + (warn + 'local-argument-mismatch + :format-control "function called with ~R argument~:P, but wants at least ~R" - call-args min-args) + :format-arguments (list call-args min-args)) (setf (basic-combination-kind call) :error)) ((<= call-args max-args) (convert-call ref call @@ -518,11 +503,12 @@ ((optional-dispatch-more-entry fun) (convert-more-call ref call fun)) (t - ;; FIXME: See FIXME note at the previous - ;; wrong-number-of-arguments warnings in this file. - (compiler-warn + (warn + 'local-argument-mismatch + :format-control "function called with ~R argument~:P, but wants at most ~R" - call-args max-args) + :format-arguments + (list call-args max-args)) (setf (basic-combination-kind call) :error)))) (values)) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 02ee7f7..7170619 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -334,24 +334,25 @@ (assert (eq (car (sb-pcl:class-direct-superclasses (find-class 'simple-condition))) (find-class 'condition))) - - (let ((subclasses (mapcar #'find-class - '(simple-type-error - simple-error - simple-warning - sb-int:simple-file-error - sb-int:simple-style-warning)))) - (assert (null (set-difference - (sb-pcl:class-direct-subclasses (find-class - 'simple-condition)) - subclasses)))) - + + #+nil ; doesn't look like a good test + (let ((subclasses (mapcar #'find-class + '(simple-type-error + simple-error + simple-warning + sb-int:simple-file-error + sb-int:simple-style-warning)))) + (assert (null (set-difference + (sb-pcl:class-direct-subclasses (find-class + 'simple-condition)) + subclasses)))) + ;; precedence lists - (assert (equal (sb-pcl:class-precedence-list - (find-class 'simple-condition)) - (mapcar #'find-class '(simple-condition - condition - sb-pcl::slot-object + (assert (equal (sb-pcl:class-precedence-list + (find-class 'simple-condition)) + (mapcar #'find-class '(simple-condition + condition + sb-pcl::slot-object sb-kernel:instance t)))) diff --git a/version.lisp-expr b/version.lisp-expr index 4463826..faa36d3 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.10.56" +"0.8.10.57" -- 1.7.10.4