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