diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 8e7a78d18926a1df4bbd5ca1b392d774ae4b9f38..f52825c8dc3c1340e367307b2a6f9ce1f1afe4d0 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.36 2003/05/10 19:09:02 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.37 2003/05/11 11:30:35 gerd Exp $") ;;; ;;; Bootstrapping the meta-braid. @@ -124,13 +124,14 @@ slot-class-wrapper slot-class built-in-class-wrapper built-in-class structure-class-wrapper structure-class + condition-class-wrapper condition-class standard-direct-slot-definition-wrapper standard-direct-slot-definition standard-effective-slot-definition-wrapper standard-effective-slot-definition class-eq-specializer-wrapper class-eq-specializer standard-generic-function-wrapper standard-generic-function) (initial-classes-and-wrappers standard-class funcallable-standard-class - slot-class built-in-class structure-class + slot-class built-in-class structure-class condition-class standard-direct-slot-definition standard-effective-slot-definition class-eq-specializer standard-generic-function) ;; @@ -146,7 +147,8 @@ (standard-class standard-class-wrapper) (funcallable-standard-class funcallable-standard-class-wrapper) (built-in-class built-in-class-wrapper) - (structure-class structure-class-wrapper))) + (structure-class structure-class-wrapper) + (condition-class condition-class-wrapper))) (class (or (find-class name nil) (allocate-standard-instance wrapper)))) (when (or (eq meta 'standard-class) @@ -182,6 +184,8 @@ built-in-class-wrapper) ((eq class structure-class) structure-class-wrapper) + ((eq class condition-class) + condition-class-wrapper) ((eq class class-eq-specializer) class-eq-specializer-wrapper) ((eq class standard-generic-function) @@ -235,6 +239,11 @@ direct-supers direct-subclasses cpl wrapper proto)) (structure-class ; *the-class-structure-object* (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper)) + (condition-class + (bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper)))))))) @@ -290,7 +299,7 @@ ,@(and default-initargs `(default-initargs ,default-initargs)))) (when (memq metaclass-name '(standard-class funcallable-standard-class - structure-class slot-class)) + structure-class slot-class condition-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) (set-slot 'initialize-info nil)) @@ -310,26 +319,28 @@ (setf (bootstrap-get-slot metaclass-name super 'direct-subclasses) (cons class subclasses)))))) ;; - (if (eq metaclass-name 'structure-class) - (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) - (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) - (make-class-predicate-name name))) - (set-slot 'defstruct-form - `(defstruct (structure-object (:constructor ,constructor-sym)))) - (set-slot 'defstruct-constructor constructor-sym) - (set-slot 'from-defclass-p t) - (set-slot 'plist nil) - (set-slot 'prototype (funcall constructor-sym))) - (set-slot 'prototype (if proto-p proto (allocate-standard-instance wrapper)))) + (case metaclass-name + (structure-class + (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) + (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) + (make-class-predicate-name name))) + (set-slot 'defstruct-form + `(defstruct (structure-object (:constructor ,constructor-sym)))) + (set-slot 'defstruct-constructor constructor-sym) + (set-slot 'from-defclass-p t) + (set-slot 'plist nil) + (set-slot 'prototype (funcall constructor-sym)))) + (condition-class + (set-slot 'prototype (make-condition name))) + (t + (set-slot 'prototype + (if proto-p proto (allocate-standard-instance wrapper))))) class)) (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) - (let ((index -1)) - (mapcar (lambda (slot) - (incf index) - (bootstrap-make-slot-definition - name class slot wrapper effective-p index)) - slots))) + (loop for index from 0 and slot in slots collect + (bootstrap-make-slot-definition name class slot wrapper + effective-p index))) (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index) (let* ((slotd-class-name (if effective-p @@ -359,10 +370,7 @@ (set-val 'boundp-function (make-optimized-std-boundp-method-function fsc-p slot-name index))) (set-val 'accessor-flags 7) - (let ((table (or (gethash slot-name *name->class->slotd-table*) - (setf (gethash slot-name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd))) + (setf (gethash class (slot-name->class-table slot-name)) slotd)) (when (and (eq name 'standard-class) (eq slot-name 'slots) effective-p) (setq *the-eslotd-standard-class-slots* slotd)) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 9cc48ce05d849483c8ffa455e168aa5d2ea1111b..bdf6e38ad0cb94512d2c633b44b5305789f9b465 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -95,6 +95,7 @@ *the-class-built-in-class* *the-class-slot-class* *the-class-std-class* + *the-class-condition-class* *the-class-structure-class* *the-class-standard-class* *the-class-funcallable-standard-class* @@ -286,6 +287,11 @@ (defvar *name->class->slotd-table* (make-hash-table)) +(defun slot-name->class-table (slot-name) + (or (gethash slot-name *name->class->slotd-table*) + (setf (gethash slot-name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5)))) + (defvar *standard-method-combination*) @@ -535,6 +541,9 @@ :initform nil :initarg :from-defclass-p))) +(defclass condition (slot-object kernel:instance) () + (:metaclass condition-class)) + (defclass condition-class (slot-class) ()) (defclass specializer-with-object (specializer) ()) @@ -808,6 +817,7 @@ was inherited." (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) (structure-class structure-class-p) + (condition-class condition-class-p) (forward-referenced-class forward-referenced-class-p) (method method-p) (standard-method standard-method-p) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index 27e1830a2753a64aa5191afd20d2ec75575cc05d..c80aefaf63dc49a63e820cd0fec06a1f057e4875 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.26 2003/05/04 13:11:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.27 2003/05/11 11:30:34 gerd Exp $") (in-package :pcl) @@ -1356,7 +1356,7 @@ And so, we are saved. (slot-accessor-std-p slotd type))) (return-from make-accessor-table nil)) (push (cons specl slotd) (gethash class table))))) - (gethash slot-name *name->class->slotd-table*)))) + (slot-name->class-table slot-name)))) (maphash (lambda (class specl+slotd-list) (dolist (sclass (precedence class) (internal-error "This can't happen.")) diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index e27f9635ddbb123e2bb4e8ed40c6a4c612140484..ca789db581362a34e02ae2066771a310b413b699 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -1,7 +1,7 @@ ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.25 2003/05/04 13:11:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.26 2003/05/11 11:30:34 gerd Exp $") ;;; (in-package :pcl) @@ -87,9 +87,7 @@ ; (standard-writer-method) (defgeneric structure-class-p (object)) -; (t) -; (structure-class) - +(defgeneric condition-class-p (object)) ;;; readers (defgeneric accessor-method-slot-definition (standard-accessor-method)) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 689473f192203bba0083cef8ac8372c007f2dcd0..87fc76a9f8c2665cca817a790783e5b6eb1d5150 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.29 2003/05/04 13:11:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.30 2003/05/11 11:30:34 gerd Exp $") (in-package :pcl) @@ -851,6 +851,9 @@ (defvar *structure-slot-value-using-class-method* nil) (defvar *structure-setf-slot-value-using-class-method* nil) (defvar *structure-slot-boundp-using-class-method* nil) +(defvar *condition-slot-value-using-class-method* nil) +(defvar *condition-setf-slot-value-using-class-method* nil) +(defvar *condition-slot-boundp-using-class-method* nil) (defun standard-svuc-method (type) (case type @@ -876,6 +879,18 @@ (writer (setq *structure-setf-slot-value-using-class-method* method)) (boundp (setq *structure-slot-boundp-using-class-method* method)))) +(defun condition-svuc-method (type) + (case type + (reader *condition-slot-value-using-class-method*) + (writer *condition-setf-slot-value-using-class-method*) + (boundp *condition-slot-boundp-using-class-method*))) + +(defun set-condition-svuc-method (type method) + (case type + (reader (setq *condition-slot-value-using-class-method* method)) + (writer (setq *condition-setf-slot-value-using-class-method* method)) + (boundp (setq *condition-boundp-using-class-method* method)))) + (defun update-std-or-str-methods (gf type) (dolist (method (generic-function-methods gf)) (let ((specls (method-specializers method))) @@ -889,6 +904,13 @@ (eq (class-name (caddr specls)) 'standard-effective-slot-definition)) (set-standard-svuc-method type method)) + ((and (eq (class-name (car specls)) + 'condition-class) + (eq (class-name (cadr specls)) + 'condition) + (eq (class-name (caddr specls)) + 'condition-effective-slot-definition)) + (set-condition-svuc-method type method)) ((and (eq (class-name (car specls)) 'structure-class) (eq (class-name (cadr specls)) diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index 9ad86050ae1f8f64c55390e60185305bd1c25f68..773acd5c16ea11248f2ec4545eba4c9f35acbb73 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.22 2003/05/07 16:59:48 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.23 2003/05/11 11:30:34 gerd Exp $") ;;; (in-package :pcl) @@ -99,9 +99,7 @@ ;; Initialize this here, In case the LOAD-TIME-VALUE is ;; executed before INITIALIZE-INTERNAL-SLOT-FUNCTIONS had a ;; chance to run. - (unless (gethash slot-name *name->class->slotd-table*) - (setf (gethash slot-name *name->class->slotd-table*) - (make-hash-table :test 'eq))) + (slot-name->class-table slot-name) (setf (plist-value gf 'slot-missing-method) t) (ecase type (reader (add-slot-missing-method gf slot-name 'slot-value)) @@ -150,23 +148,30 @@ (lambda (object) (declare (ignore object)) t)) (defun get-optimized-std-accessor-method-function (class slotd name) - (if (structure-class-p class) - (ecase name - (reader (slot-definition-internal-reader-function slotd)) - (writer (slot-definition-internal-writer-function slotd)) - (boundp (make-structure-slot-boundp-function slotd))) - (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - (t (error "~@<~S is not a standard-class.~@:>" class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function (ecase name - (reader #'make-optimized-std-reader-method-function) - (writer #'make-optimized-std-writer-method-function) - (boundp #'make-optimized-std-boundp-method-function))) - (value (funcall function fsc-p slot-name index))) - (declare (type function function)) - (values value index)))) + (cond ((structure-class-p class) + (ecase name + (reader (slot-definition-internal-reader-function slotd)) + (writer (slot-definition-internal-writer-function slotd)) + (boundp (make-structure-slot-boundp-function slotd)))) + ((condition-class-p class) + (ecase name + (reader (slot-definition-reader-function slotd)) + (writer (slot-definition-writer-function slotd)) + (boundp (slot-definition-boundp-function slotd)))) + (t + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~@<~S is not a standard-class.~@:>" + class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function (ecase name + (reader #'make-optimized-std-reader-method-function) + (writer #'make-optimized-std-writer-method-function) + (boundp #'make-optimized-std-boundp-method-function))) + (value (funcall function fsc-p slot-name index))) + (declare (type function function)) + (values value index))))) (defun make-optimized-std-reader-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) @@ -245,28 +250,49 @@ t)) (defun get-optimized-std-slot-value-using-class-method-function (class slotd name) - (if (structure-class-p class) - (ecase name - (reader (make-optimized-structure-slot-value-using-class-method-function - (slot-definition-internal-reader-function slotd))) - (writer (make-optimized-structure-setf-slot-value-using-class-method-function - (slot-definition-internal-writer-function slotd))) - (boundp (make-optimized-structure-slot-boundp-using-class-method-function))) - (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - (t (error "~@<~S is not a standard-class.~@:>" class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function - (ecase name - (reader - #'make-optimized-std-slot-value-using-class-method-function) - (writer - #'make-optimized-std-setf-slot-value-using-class-method-function) - (boundp - #'make-optimized-std-slot-boundp-using-class-method-function)))) - (declare (type function function)) - (values (funcall function fsc-p slot-name index) index)))) + (cond ((structure-class-p class) + (ecase name + (reader + (make-optimized-structure-slot-value-using-class-method-function + (slot-definition-internal-reader-function slotd))) + (writer + (make-optimized-structure-setf-slot-value-using-class-method-function + (slot-definition-internal-writer-function slotd))) + (boundp + (make-optimized-structure-slot-boundp-using-class-method-function)))) + ((condition-class-p class) + (ecase name + (reader + (let ((function (slot-definition-reader-function slotd))) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall function object)))) + (writer + (let ((function (slot-definition-writer-function slotd))) + (lambda (nv class object slotd) + (declare (ignore class slotd)) + (funcall function nv object)))) + (boundp + (let ((function (slot-definition-boundp-function slotd))) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall function object)))))) + (t + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~@<~S is not a standard-class.~@:>" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) + (declare (type function function)) + (values (funcall function fsc-p slot-name index) index))))) (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slot-name index) diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 829dbd288f916d51ac3255619dc586604b3655c4..bdad9c7dd0a2bda6e89929ed96d79f5feff739b7 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.22 2003/05/10 20:27:23 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.23 2003/05/11 11:30:34 gerd Exp $") ;;; (in-package :pcl) @@ -267,13 +267,37 @@ (slotd structure-effective-slot-definition)) (error "Structure slots cannot be unbound.")) + +(defmethod slot-value-using-class + ((class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fn (slot-definition-reader-function slotd))) + (declare (type function fn)) + (funcall fn object))) + +(defmethod (setf slot-value-using-class) + (new-value + (class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fn (slot-definition-writer-function slotd))) + (declare (type function fn)) + (funcall fn new-value object))) + +(defmethod slot-boundp-using-class + ((class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fn (slot-definition-boundp-function slotd))) + (declare (type function fn)) + (funcall fn object))) (defmethod slot-makunbound-using-class ((class condition-class) object slot) (declare (ignore object slot)) (error "Condition slots cannot be unbound.")) - (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) (error @@ -314,4 +338,3 @@ (error "~@<Can't allocate an instance of class ~S.~@:>" (class-name class))))) - diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index ca947a750f768ee0fd4bbe548e346b5fc839ee4f..3a36e173dd1cd4df8df985dc4f064f45d259ea91 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.64 2003/05/10 20:27:23 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.65 2003/05/11 11:30:34 gerd Exp $") (in-package :pcl) @@ -76,10 +76,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd 'class))) - (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd)) + (setf (gethash class (slot-name->class-table name)) slotd) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type (reader 'slot-value-using-class) @@ -1602,7 +1599,12 @@ (add-direct-subclasses class direct-superclasses) (setq predicate-name (make-class-predicate-name (class-name class))) (make-class-predicate class predicate-name) - (setf (slot-value class 'slots) (compute-slots class))))) + (setf (slot-value class 'slots) (compute-slots class)))) + ;; + ;; We don't ADD-SLOT-ACCESSORS here because we don't want to + ;; override condition accessors with generic functions. We do this + ;; differently. + (update-pv-table-cache-info class)) (defmethod direct-slot-definition-class ((class condition-class) &rest initargs) @@ -1645,3 +1647,7 @@ (class-direct-slots superclass))) (reverse (slot-value class 'class-precedence-list)))) +(defmethod compute-slots :around ((class condition-class)) + (let ((eslotds (call-next-method))) + (mapc #'initialize-internal-slot-functions eslotds) + eslotds))