From 04f6e86bf94ea1718fbe2dc67960a2f4715b1ab7 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 3 Jan 2006 18:09:55 +0000
Subject: [PATCH] o Add new condition REFERENCE-CONDITION which is used to
 include   reference information for other conditions.  This condition prints 
  out a short message saying to look somewhere appropriate. o Use
 REFERENCE-CONDITION for the CONSTANT-MODIFIED condition.

(Based on SBCL's REFERENCE-CONDITION.)

This needs work to add more references.
---
 code/error.lisp | 56 ++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 53 insertions(+), 3 deletions(-)

diff --git a/code/error.lisp b/code/error.lisp
index 61991ae05..bab4d84a8 100644
--- a/code/error.lisp
+++ b/code/error.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/error.lisp,v 1.84 2005/10/21 17:56:07 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.85 2006/01/03 18:09:55 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1001,6 +1001,54 @@
 (define-condition stream-error  (error)
   ((stream :reader stream-error-stream :initarg :stream)))
 
+(defun print-reference (reference stream)
+  (ecase (car reference)
+    (:amop
+     (format stream "AMOP")
+     (format stream ", ")
+     (destructuring-bind (type data) (cdr reference)
+       (ecase type
+         (:generic-function (format stream "Generic Function ~S" data))
+         (:section (format stream "Section ~{~D~^.~}" data)))))
+    (: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 for ~S" data))
+         (:issue (format stream "writeup for Issue ~A" data)))))
+    #+nil
+    (:cmucl
+     (format stream "The CMUCL Manual")
+     (format stream ", ")
+     (destructuring-bind (type data) (cdr reference)
+       (ecase type
+         (:node (format stream "Node ~S" data))
+         (:variable (format stream "Variable ~S" data))
+         (:function (format stream "Function ~S" data)))))
+    ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
+    ))
+
+(defun print-references (refs stream)
+  (unless (or *print-escape* *print-readably*)
+    (when refs
+      (format stream "~&See also:~%")
+      (pprint-logical-block (stream refs :per-line-prefix "  ")
+	(do* ((rs refs (cdr rs))
+	      (r (car rs) (car rs)))
+	     ((null rs))
+	  (print-reference r stream)
+	  (unless (null (cdr rs))
+	    (terpri stream)))))))
+
+(define-condition reference-condition ()
+  ((references :initarg :references
+	       :reader reference-condition-references)))
+
 (define-condition end-of-file (stream-error) ()
   (:report
    (lambda (condition stream)
@@ -1049,12 +1097,14 @@
 (define-condition simple-undefined-function (simple-condition
 					     undefined-function) ())
 
-(define-condition constant-modified (warning)
+(define-condition constant-modified (reference-condition warning)
   ((function-name :initarg :function-name :reader constant-modified-function-name))
   (:report (lambda (c s)
              (format s "~@<Destructive function ~S called on ~
                          constant data.~@:>"
-                     (constant-modified-function-name c)))))
+                     (constant-modified-function-name c))
+	     (print-references (reference-condition-references c) s)))
+  (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
   
 (define-condition arithmetic-error (error)
   ((operation :reader arithmetic-error-operation :initarg :operation
-- 
GitLab