X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=558d920f3bec45a6f32cac08153b26185031762f;hb=50f728671defadb8f7b1e8691c984cb0e6aba17c;hp=c089b0577ed0a770844168761307343c397bf348;hpb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index c089b05..558d920 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -322,30 +322,29 @@ :definition-source `((defclass ,name) ,*load-pathname*) other))) - ;; Defclass of a class with a forward-referenced superclass does not - ;; have a wrapper. RES is the incomplete PCL class. The Lisp class - ;; does not yet exist. Maybe should return NIL in that case as RES - ;; is not useful to the user? - (and (class-wrapper res) (sb-kernel:layout-class (class-wrapper res))))) + res)) (setf (gdefinition 'load-defclass) #'real-load-defclass) (defun ensure-class (name &rest all) - (apply #'ensure-class-using-class name (find-class name nil) all)) + (apply #'ensure-class-using-class (find-class name nil) name all)) -(defmethod ensure-class-using-class (name (class null) &rest args &key) +(defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) + (set-class-type-translation (class-prototype meta) name) (setf class (apply #'make-instance meta :name name initargs) (find-class name) class) + (set-class-type-translation class name) class)) -(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) +(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) (unless (eq (class-of class) meta) (change-class class meta)) (apply #'reinitialize-instance class initargs) (setf (find-class name) class) + (set-class-type-translation class name) class)) (defmethod class-predicate-name ((class t)) @@ -444,15 +443,15 @@ (remf initargs :metaclass) (loop (unless (remf initargs :direct-superclasses) (return))) (loop (unless (remf initargs :direct-slots) (return))) - (values meta - (list* :direct-superclasses - (and (neq supplied-supers unsupplied) - (mapcar #'fix-super supplied-supers)) - :direct-slots - (and (neq supplied-slots unsupplied) supplied-slots) - initargs)))) + (values + meta + (nconc + (when (neq supplied-supers unsupplied) + (list :direct-superclasses (mapcar #'fix-super supplied-supers))) + (when (neq supplied-slots unsupplied) + (list :direct-slots supplied-slots)) + initargs)))) - (defmethod shared-initialize :after ((class std-class) slot-names @@ -531,6 +530,22 @@ (lambda (dependent) (apply #'update-dependent class dependent initargs)))) +(defmethod shared-initialize :after ((class condition-class) slot-names + &key direct-superclasses) + (declare (ignore slot-names)) + (let ((classoid (find-classoid (class-name class)))) + (with-slots (wrapper class-precedence-list prototype predicate-name + (direct-supers direct-superclasses)) + class + (setf (classoid-pcl-class classoid) class) + (setq direct-supers direct-superclasses) + (setq wrapper (classoid-layout classoid)) + (setq class-precedence-list (compute-class-precedence-list class)) + (setq prototype (make-condition (class-name class))) + (add-direct-subclasses class direct-superclasses) + (setq predicate-name (make-class-predicate-name (class-name class))) + (make-class-predicate class predicate-name)))) + (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key (allocation :instance) allocation-class) @@ -553,18 +568,14 @@ +slot-unbound+)) direct-slots))) (reader-names (mapcar (lambda (slotd) - (intern (format nil - "~A~A reader" - conc-name - (slot-definition-name - slotd)))) + (list 'slot-accessor name + (slot-definition-name slotd) + 'reader)) direct-slots)) (writer-names (mapcar (lambda (slotd) - (intern (format nil - "~A~A writer" - conc-name - (slot-definition-name - slotd)))) + (list 'slot-accessor name + (slot-definition-name slotd) + 'writer)) direct-slots)) (readers-init (mapcar (lambda (slotd reader-name) @@ -645,9 +656,9 @@ (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'slots) (compute-slots class)) - (let ((lclass (cl:find-class (class-name class)))) - (setf (sb-kernel:class-pcl-class lclass) class) - (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass))) + (let ((lclass (find-classoid (class-name class)))) + (setf (classoid-pcl-class lclass) class) + (setf (slot-value class 'wrapper) (classoid-layout lclass))) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) @@ -658,7 +669,7 @@ (class-name class)))))) (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots))) - + (defmethod direct-slot-definition-class ((class structure-class) initargs) (declare (ignore initargs)) (find-class 'structure-direct-slot-definition)) @@ -1133,7 +1144,7 @@ ;;; obsolete the wrapper. ;;; ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place -;;; for (AVER (NOT (EQ (SB-KERNEL:LAYOUT-INVALID OWRAPPER) +;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER) ;;; :UNINITIALIZED))) ;;; ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29 @@ -1149,14 +1160,14 @@ ;; a violation of locality or what might be considered ;; good style. There has to be a better way! -- CSR, ;; 2002-10-29 - (eq (sb-kernel:layout-invalid owrapper) t)) + (eq (layout-invalid owrapper) t)) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) (setf (wrapper-instance-slots-layout nwrapper) (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) - (sb-sys:without-interrupts + (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper :flush nwrapper)))))) @@ -1176,7 +1187,7 @@ (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) - (sb-sys:without-interrupts + (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper :obsolete nwrapper)