Skip to content
Snippets Groups Projects
Commit 897b08d2 authored by gerd's avatar gerd
Browse files

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.
parent 57aa48d9
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -640,6 +640,45 @@
(res (copy-structure sslot))))))) (res (copy-structure sslot)))))))
(res))) (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) (defun %define-condition (name slots documentation report default-initargs)
(let ((class (kernel::find-class name))) (let ((class (kernel::find-class name)))
...@@ -649,19 +688,13 @@ ...@@ -649,19 +688,13 @@
(setf (condition-class-default-initargs class) default-initargs) (setf (condition-class-default-initargs class) default-initargs)
(setf (documentation name 'type) documentation) (setf (documentation name 'type) documentation)
(dolist (slot slots) (unless *make-condition-accessor-methods*
;; (dolist (slot slots)
;; Set up reader & writer functions. (let ((slot-name (condition-slot-name slot)))
(let ((name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot))
(dolist (reader (condition-slot-readers slot)) (make-condition-accessor reader name slot-name 'reader nil))
(setf (fdefinition reader) (dolist (writer (condition-slot-writers slot))
#'(lambda (condition) (make-condition-accessor writer name slot-name 'writer nil)))))
(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))))))
;; ;;
;; Compute effective slots and set up the class and hairy slots (subsets of ;; Compute effective slots and set up the class and hairy slots (subsets of
;; the effective slots.) ;; the effective slots.)
...@@ -723,6 +756,7 @@ ...@@ -723,6 +756,7 @@
(layout (find-condition-layout name parent-types)) (layout (find-condition-layout name parent-types))
(documentation nil) (documentation nil)
(report nil) (report nil)
(slot-name/accessors ())
(default-initargs ())) (default-initargs ()))
(collect ((slots) (collect ((slots)
(all-readers nil append) (all-readers nil append)
...@@ -765,6 +799,7 @@ ...@@ -765,6 +799,7 @@
(simple-program-error "Unknown slot option:~% ~S" (simple-program-error "Unknown slot option:~% ~S"
(first options)))))) (first options))))))
(push (list slot-name (readers) (writers)) slot-name/accessors)
(all-readers (readers)) (all-readers (readers))
(all-writers (writers)) (all-writers (writers))
(slots `(make-condition-slot (slots `(make-condition-slot
...@@ -812,6 +847,18 @@ ...@@ -812,6 +847,18 @@
(declaim (ftype (function (t) t) ,@(all-readers))) (declaim (ftype (function (t) t) ,@(all-readers)))
(declaim (ftype (function (t t) t) ,@(all-writers))) (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 (%define-condition ',name
(list ,@(slots)) (list ,@(slots))
,documentation ,documentation
......
...@@ -42,6 +42,7 @@ New in this release: ...@@ -42,6 +42,7 @@ New in this release:
- RESTART-CASE's interaction with local macros fixed. - RESTART-CASE's interaction with local macros fixed.
- Interaction of COMPUTE-RESTARTS and RESTART-CASE fixed in - Interaction of COMPUTE-RESTARTS and RESTART-CASE fixed in
presence of multiple restarts having the same name. presence of multiple restarts having the same name.
- Condition slot readers/writers are generic functions.
* Numerous bugfixes: * Numerous bugfixes:
......
...@@ -46,3 +46,8 @@ ...@@ -46,3 +46,8 @@
(ctor-class-name ctor) (ctor-class-name ctor)
(ctor-initargs ctor) (ctor-initargs ctor)
(ctor-state 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)))
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
(ext:file-comment (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 @@ ...@@ -23,8 +23,12 @@
(setf (compiler-macro-function 'slot-value) nil) (setf (compiler-macro-function 'slot-value) nil)
(setf (compiler-macro-function 'slot-boundp) nil) (setf (compiler-macro-function 'slot-boundp) nil)
;; ;;
;; Undefine all generic functions exported from Lisp so that bootstrapping ;; Undefine all generic functions exported from Lisp so that
;; doesn't get confused. ;; 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))) (let ((class (kernel::find-class 'generic-function nil)))
(when class (when class
(do-external-symbols (sym "LISP") (do-external-symbols (sym "LISP")
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -19,6 +19,9 @@
(defvar *byte-compile* #+small t #-small :maybe) (defvar *byte-compile* #+small t #-small :maybe)
(defvar *original-%deftype* #'lisp::%deftype) (defvar *original-%deftype* #'lisp::%deftype)
(when (boundp 'conditions::*make-condition-accessor-methods*)
(setq conditions::*make-condition-accessor-methods* nil))
(with-compiler-log-file (with-compiler-log-file
("target:compile-lisp.log" ("target:compile-lisp.log"
:optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2) :optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment