X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=f7ee4f1306db42c4206078a8b843b4686165dca3;hb=ed3295bc583cd14104130441e9ff1ad40fa5e484;hp=fc53ebd30d335b1201f69eeaad13ec5fe8ae6e98;hpb=9ce24dc604859d2670a989da2a9015b67c37e00f;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index fc53ebd..f7ee4f1 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -83,8 +83,7 @@ (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) - (initialize-internal-slot-gfs name))) + (compute-slot-accessor-info slotd type gf))))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: ;;; @@ -291,14 +290,13 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names) + readers writers slot-names source-location) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots - :definition-source `((defclass ,name) - ,*load-pathname*) + :definition-source source-location other))) res))) @@ -334,9 +332,6 @@ (set-class-type-translation class name) class)) -(defmethod class-predicate-name ((class t)) - 'constantly-nil) - (defun fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) @@ -368,12 +363,10 @@ (defmethod shared-initialize :after - ((class std-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs nil direct-default-initargs-p) - (predicate-name nil predicate-name-p)) + ((class std-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p)) (cond (direct-superclasses-p (setq direct-superclasses (or direct-superclasses @@ -420,15 +413,7 @@ (push (cons name value) collect)) (push old collect))))) (nreverse collect))) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) (add-direct-subclasses class direct-superclasses) - (make-class-predicate class predicate-name) (update-class class nil) (do* ((slots (slot-value class 'slots) (cdr slots)) (dupes nil)) @@ -515,13 +500,27 @@ (lambda (dependent) (apply #'update-dependent class dependent initargs)))) +(defmethod reinitialize-instance :after ((class condition-class) &key) + (let* ((name (class-name class)) + (classoid (find-classoid name)) + (slots (condition-classoid-slots classoid))) + ;; to balance the REMOVE-SLOT-ACCESSORS call in + ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS). + (dolist (slot slots) + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + ;; FIXME: see comment in SHARED-INITIALIZE :AFTER + ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18 + (sb-kernel::install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (sb-kernel::install-condition-slot-writer writer name slot-name)))))) + (defmethod shared-initialize :after ((class condition-class) slot-names &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) (with-slots (wrapper class-precedence-list cpl-available-p - prototype predicate-name - (direct-supers direct-superclasses)) + prototype (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) (mapcar (lambda (pl) (make-direct-slotd class pl)) @@ -533,14 +532,20 @@ (setq class-precedence-list (compute-class-precedence-list class)) (setq cpl-available-p t) (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)))) ;; Comment from Gerd's PCL, 2003-05-15: ;; ;; We don't ADD-SLOT-ACCESSORS here because we don't want to ;; override condition accessors with generic functions. We do this ;; differently. + ;; + ;; ??? What does the above comment mean and why is it a good idea? + ;; CMUCL (which still as of 2005-11-18 uses this code and has this + ;; comment) loses slot information in its condition classes: + ;; DIRECT-SLOTS is always NIL. We have the right information, so we + ;; remove slot accessors but never put them back. I've added a + ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what + ;; was meant to happen? -- CSR, 2005-11-18 (update-pv-table-cache-info class)) (defmethod direct-slot-definition-class ((class condition-class) @@ -654,12 +659,10 @@ (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after - ((class structure-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) + ((class structure-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) - direct-default-initargs - (predicate-name nil predicate-name-p)) + direct-default-initargs) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) @@ -693,7 +696,7 @@ (unless (structure-type-p name) (eval defstruct-form)) (mapc (lambda (dslotd reader-name writer-name) (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) + (writer (when (fboundp writer-name) (gdefinition writer-name)))) (setf (slot-value dslotd 'internal-reader-function) reader) @@ -714,14 +717,6 @@ (setf (slot-value class 'wrapper) (classoid-layout lclass))) (setf (slot-value class 'finalized-p) t) (update-pv-table-cache-info class) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name - (class-name class)))))) - (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots))) (defmethod direct-slot-definition-class ((class structure-class) &rest initargs) @@ -1019,9 +1014,9 @@ ;; do if we find that said user has added a slot ;; with the same name as another slot... (cell (or (assq name (class-slot-cells from-class)) - (setf (class-slot-cells from-class) - (cons (cons name +slot-unbound+) - (class-slot-cells from-class)))))) + (let ((c (cons name +slot-unbound+))) + (push c (class-slot-cells from-class)) + c)))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) ;; We may have inherited an initfunction @@ -1079,6 +1074,8 @@ (allocation nil) (allocation-class nil) (type t) + (documentation nil) + (documentationp nil) (namep nil) (initp nil) (allocp nil)) @@ -1093,15 +1090,24 @@ (setq initform (slot-definition-initform slotd) initfunction (slot-definition-initfunction slotd) initp t))) + (unless documentationp + (when (%slot-definition-documentation slotd) + (setq documentation (%slot-definition-documentation slotd) + documentationp t))) (unless allocp (setq allocation (slot-definition-allocation slotd) allocation-class (slot-definition-class slotd) allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) (let ((slotd-type (slot-definition-type slotd))) - (setq type (cond ((eq type t) slotd-type) - ((*subtypep type slotd-type) type) - (t `(and ,type ,slotd-type))))))) + (setq type (cond + ((eq type t) slotd-type) + ;; This pairwise type intersection is perhaps a + ;; little inefficient and inelegant, but it's + ;; unlikely to lie on the critical path. Shout + ;; if I'm wrong. -- CSR, 2005-11-24 + (t (type-specifier + (specifier-type `(and ,type ,slotd-type))))))))) (list :name name :initform initform :initfunction initfunction @@ -1109,7 +1115,8 @@ :allocation allocation :allocation-class allocation-class :type type - :class class))) + :class class + :documentation documentation))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) @@ -1431,14 +1438,55 @@ (apply #'update-instance-for-different-class copy instance initargs) instance)) -(defmethod change-class ((instance standard-object) - (new-class standard-class) +(defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) + (change-class-internal instance new-class initargs)) + +(defmethod change-class ((instance forward-referenced-class) + (new-class standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl + (error 'metaobject-initialization-violation + :format-control + "~@" + :format-arguments + (list 'change-class 'forward-referenced-class 'class) + :references + (list '(:amop :generic-function ensure-class-using-class) + '(:amop :initialization class)))) + (when (eq class (find-class 'class)) + (return nil)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) (new-class funcallable-standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance standard-object) @@ -1469,15 +1517,24 @@ ;;;; But, there are other parts of the protocol we must follow and those ;;;; definitions appear here. -(defmethod shared-initialize :before - ((class built-in-class) slot-names &rest initargs) - (declare (ignore slot-names initargs)) - (error "attempt to initialize or reinitialize a built in class")) - -(defmethod class-direct-slots ((class built-in-class)) ()) -(defmethod class-slots ((class built-in-class)) ()) -(defmethod class-direct-default-initargs ((class built-in-class)) ()) -(defmethod class-default-initargs ((class built-in-class)) ()) +(macrolet ((def (name args control) + `(defmethod ,name ,args + (declare (ignore initargs)) + (error 'metaobject-initialization-violation + :format-control ,(format nil "~@<~A~@:>" control) + :format-arguments (list ',name) + :references (list '(:amop :initialization "Class")))))) + (def initialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.") + (def reinitialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.")) + +(macrolet ((def (name) + `(defmethod ,name ((class built-in-class)) nil))) + (def class-direct-slots) + (def class-slots) + (def class-direct-default-initargs) + (def class-default-initargs)) (defmethod validate-superclass ((c class) (s built-in-class)) (or (eq s *the-class-t*) (eq s *the-class-stream*)