From 897b08d293dc227449a52cdba2235324bcddb2a0 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Fri, 18 Apr 2003 10:24:32 +0000
Subject: [PATCH] 	Make condition readers/writers generic functions, as
 required by 	ANSI.  Detected by Paul Dietz' ANSI test suite.

	* src/tools/worldcom.lisp: Set
	conditions::*make-condition-accessor-methods* to nil.

	* src/tools/pclcom.lisp: Convert condition accessor gfs back
	to normal functions.

	* src/code/error.lisp (*make-condition-accessor-methods*)
	(*early-condition-accessors*): New variables.
	(make-early-condition-accessors-generic)
	(make-condition-accessor): New functions.
	(%define-condition): Use make-condition-accessor.
	(define-condition): Define methods if
	*make-condition-accessor-methods*.

	* src/pcl/fixup.lisp (toplevel): Call
	conditions::make-early-condition-accessors-generic.
---
 code/error.lisp              | 75 +++++++++++++++++++++++++++++-------
 general-info/release-19a.txt |  1 +
 pcl/fixup.lisp               |  5 +++
 tools/pclcom.lisp            | 10 +++--
 tools/worldcom.lisp          |  5 ++-
 5 files changed, 78 insertions(+), 18 deletions(-)

diff --git a/code/error.lisp b/code/error.lisp
index d85c90c8c..15fc92224 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.71 2003/04/17 13:12:28 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.72 2003/04/18 10:24:32 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -640,6 +640,45 @@
 		 (res (copy-structure sslot)))))))
     (res)))
 
+(eval-when (compile load eval)
+  (defvar *make-condition-accessor-methods* nil))
+
+;;;
+;;; List of condition slot readers and writers defined early.  Used to
+;;; change them to generic functions when PCL is ready to do so.
+;;; Alas, we have to keep this list around after readers/writers have
+;;; been made generic functions because the PCL build process requires
+;;; us to undefine generic functions, so we need to change the
+;;; accessors back to normal functions when building PCL.
+;;;
+(defvar *early-condition-accessors* ())
+
+(defun make-early-condition-accessors-generic (&optional (generic-p t))
+  (dolist (elt *early-condition-accessors*)
+    (destructuring-bind (condition slot accessor kind) elt
+      (fmakunbound accessor)
+      (let ((new (make-condition-accessor accessor condition slot
+					  kind generic-p))) 
+	(when generic-p
+	  (eval new)))))
+  (setq *make-condition-accessor-methods* generic-p))
+
+(defun make-condition-accessor (accessor condition slot kind generic-p)
+  (if generic-p
+      (if (eq kind 'reader)
+	  `(defmethod ,accessor ((x ,condition))
+	     (condition-reader-function x ',slot))
+	  `(defmethod ,accessor (nv (x ,condition))
+	     (condition-writer-function x nv ',slot)))
+      (progn
+	(pushnew (list condition slot accessor kind)
+		 *early-condition-accessors* :test #'equal)
+	(setf (fdefinition accessor)
+	      (if (eq kind 'reader)
+		  (lambda (x)
+		    (condition-reader-function x slot))
+		  (lambda (nv x)
+		    (condition-writer-function x nv slot)))))))
 
 (defun %define-condition (name slots documentation report default-initargs)
   (let ((class (kernel::find-class name)))
@@ -649,19 +688,13 @@
     (setf (condition-class-default-initargs class) default-initargs)
     (setf (documentation name 'type) documentation)
     
-    (dolist (slot slots)
-      ;;
-      ;; Set up reader & writer functions.
-      (let ((name (condition-slot-name slot)))
-	(dolist (reader (condition-slot-readers slot))
-	  (setf (fdefinition reader)
-		#'(lambda (condition)
-		    (condition-reader-function condition name))))
-	(dolist (writer (condition-slot-writers slot))
-	  (setf (fdefinition writer)
-		#'(lambda (new-value condition)
-		    (condition-writer-function condition new-value name))))))
-
+    (unless *make-condition-accessor-methods*
+      (dolist (slot slots)
+	(let ((slot-name (condition-slot-name slot)))
+	  (dolist (reader (condition-slot-readers slot))
+	    (make-condition-accessor reader name slot-name 'reader nil))
+	  (dolist (writer (condition-slot-writers slot))
+	    (make-condition-accessor writer name slot-name 'writer nil)))))
     ;;
     ;; Compute effective slots and set up the class and hairy slots (subsets of
     ;; the effective slots.)
@@ -723,6 +756,7 @@
 	 (layout (find-condition-layout name parent-types))
 	 (documentation nil)
 	 (report nil)
+	 (slot-name/accessors ())
 	 (default-initargs ()))
     (collect ((slots)
 	      (all-readers nil append)
@@ -765,6 +799,7 @@
 		   (simple-program-error "Unknown slot option:~%  ~S"
                                          (first options))))))
 
+	    (push (list slot-name (readers) (writers)) slot-name/accessors)
 	    (all-readers (readers))
 	    (all-writers (writers))
 	    (slots `(make-condition-slot
@@ -812,6 +847,18 @@
 	 (declaim (ftype (function (t) t) ,@(all-readers)))
 	 (declaim (ftype (function (t t) t) ,@(all-writers)))
 
+	 ,@(when *make-condition-accessor-methods*
+	     (collect ((methods))
+	       (dolist (elt slot-name/accessors)
+		 (destructuring-bind (slot-name readers writers) elt
+		   (dolist (reader readers)
+		     (methods (make-condition-accessor
+			       reader name slot-name 'reader t)))
+		   (dolist (writer writers)
+		     (methods (make-condition-accessor
+			       writer name slot-name 'writer t)))))
+	       (methods)))
+
 	 (%define-condition ',name
 			    (list ,@(slots))
 			    ,documentation
diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index 9e514bf2d..c4776607d 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -42,6 +42,7 @@ New in this release:
      - RESTART-CASE's interaction with local macros fixed.
      - Interaction of COMPUTE-RESTARTS and RESTART-CASE fixed in
        presence of multiple restarts having the same name.
+     - Condition slot readers/writers are generic functions.
 
   * Numerous bugfixes:
 
diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp
index 0b354b32a..682073970 100644
--- a/pcl/fixup.lisp
+++ b/pcl/fixup.lisp
@@ -46,3 +46,8 @@
 	    (ctor-class-name ctor)
 	    (ctor-initargs ctor)
 	    (ctor-state ctor))))
+
+(/show "Converting condition accessors")
+(when (fboundp 'conditions::make-early-condition-accessors-generic)
+  (let ((*compile-print* nil))
+    (conditions::make-early-condition-accessors-generic)))
diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp
index 4fc2a5189..b142ec5c0 100644
--- a/tools/pclcom.lisp
+++ b/tools/pclcom.lisp
@@ -3,7 +3,7 @@
 ;;; **********************************************************************
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.26 2003/04/06 09:39:24 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.27 2003/04/18 10:24:32 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -23,8 +23,12 @@
   (setf (compiler-macro-function 'slot-value) nil)
   (setf (compiler-macro-function 'slot-boundp) nil)
   ;;
-  ;; Undefine all generic functions exported from Lisp so that bootstrapping
-  ;; doesn't get confused.
+  ;; Undefine all generic functions exported from Lisp so that
+  ;; bootstrapping doesn't get confused, but convert condition
+  ;; accessor gfs to normal functions beforehand, for the obvious
+  ;; reason.
+  (when (fboundp 'conditions::make-early-condition-accessors-generic)
+    (conditions::make-early-condition-accessors-generic nil))
   (let ((class (kernel::find-class 'generic-function nil)))
     (when class
       (do-external-symbols (sym "LISP")
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index f291c4ac7..b3f486a03 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.85 2003/04/11 15:28:12 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.86 2003/04/18 10:24:32 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -19,6 +19,9 @@
 (defvar *byte-compile* #+small t #-small :maybe)
 (defvar *original-%deftype* #'lisp::%deftype)
 
+(when (boundp 'conditions::*make-condition-accessor-methods*)
+  (setq conditions::*make-condition-accessor-methods* nil))
+
 (with-compiler-log-file
     ("target:compile-lisp.log"
      :optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2)
-- 
GitLab