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

@@ -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)

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:

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"

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
-	     "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
-	     (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 for ~S found in ~
+                        one file.~@:>"
+		     (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
+	     "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
+	     (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) ()

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))

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.

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,

src/compiler/ctype.lisp

@@ -850,7 +850,8 @@
       (let ((atype (lvar-value atype))
             (dtype (lvar-value dtype)))
       (unless (eq atype nil)
-        (compiler-warn
-         "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
-         atype dtype))))
+        (warn 'type-warning
+	      :format-control 
+	      "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+	      :format-arguments (list atype dtype)))))
     (ir2-convert-full-call node block)))

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

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.

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 "~@<Duplicate definition for ~S found in ~
-                          one static unit (usually a file).~@:>"
-			 name)
+	  (warn 'duplicate-definition :name name)
 	  (push name *fun-names-in-this-file*)))
 
     (become-defined-fun-name name)

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))