diff --git a/code/error.lisp b/code/error.lisp index d85c90c8c4b7a232b403e3c2fc63ecebbabfb8e0..15fc92224f2535b0c5af5c0fa7699a380fc5fe45 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 9e514bf2d0bc34e1b1d808a85fc8dfc7746917c8..c4776607ddbcfc4ff89862f71fa77d5fc39c3150 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 0b354b32ad0a6d939a258f8527fc14b48da446a6..682073970cc2a061338d32e1b45875542cb0dc26 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 4fc2a5189cd50786da8eeb444dab27525c7dbcf9..b142ec5c0ce9dba2c3b0533197bfbcb602b8aa58 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 f291c4ac72a27357c5e811e77b7cd3a893926cf9..b3f486a03bfc3170c9f124032f002fee7e220f22 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)