(defmethod specializer-method-table ((specializer class-eq-specializer))
*class-eq-specializer-methods*)
-(defmethod add-direct-method ((specializer specializer-with-object) (method method))
+(defmethod add-direct-method ((specializer specializer-with-object)
+ (method method))
(let* ((object (specializer-object specializer))
(table (specializer-method-table specializer))
(entry (gethash object table)))
(cdr entry) ())
method))
-(defmethod remove-direct-method ((specializer specializer-with-object) (method method))
+(defmethod remove-direct-method ((specializer specializer-with-object)
+ (method method))
(let* ((object (specializer-object specializer))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(car (gethash (specializer-object specializer)
(specializer-method-table specializer))))
-(defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
+(defmethod specializer-direct-generic-functions ((specializer
+ specializer-with-object))
(let* ((object (specializer-object specializer))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(defun map-all-generic-functions (function)
(let ((all-generic-functions (make-hash-table :test 'eq)))
(map-specializers #'(lambda (specl)
- (dolist (gf (specializer-direct-generic-functions specl))
+ (dolist (gf (specializer-direct-generic-functions
+ specl))
(unless (gethash gf all-generic-functions)
(setf (gethash gf all-generic-functions) t)
(funcall function gf))))))
nil)
-(defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
+(defmethod shared-initialize :after ((specl class-eq-specializer)
+ slot-names
+ &key)
(declare (ignore slot-names))
(setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
(declare (ignore slot-names))
(setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
\f
-(defun real-load-defclass (name metaclass-name supers slots other accessors)
- (do-standard-defsetfs-for-defclass accessors) ;***
+(defun real-load-defclass (name metaclass-name supers slots other)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
:direct-superclasses supers
:direct-slots slots
(defmethod ensure-class-using-class (name (class null) &rest args &key)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
- (inform-type-system-about-class (class-prototype meta) name);***
(setf class (apply #'make-instance meta :name name initargs)
(find-class name) class)
- (inform-type-system-about-class class name) ;***
+ (inform-type-system-about-class class name)
class))
(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
(unless (eq (class-of class) meta) (change-class class meta))
(apply #'reinitialize-instance class initargs)
(setf (find-class name) class)
- (inform-type-system-about-class class name) ;***
+ (inform-type-system-about-class 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))
+ (error "~S is not a class or a legal class name." s))
+ (t
+ (or (find-class s nil)
+ (setf (find-class s)
+ (make-instance 'forward-referenced-class
+ :name s))))))
+
(defun ensure-class-values (class args)
(let* ((initargs (copy-list args))
(unsupplied (list 1))
*the-class-standard-class*)
(t
(class-of class)))))
- (flet ((fix-super (s)
- (cond ((classp s) s)
- ((not (legal-class-name-p s))
- (error "~S is not a class or a legal class name." s))
- (t
- (or (find-class s nil)
- (setf (find-class s)
- (make-instance 'forward-referenced-class
- :name s)))))))
- (loop (unless (remf initargs :metaclass) (return)))
- (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)))))
+ (loop (unless (remf initargs :metaclass) (return)))
+ (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))))
\f
-#|| ; since it doesn't do anything
-(defmethod shared-initialize :before ((class std-class)
- slot-names
- &key direct-superclasses)
- (declare (ignore slot-names))
- ;; *** error checking
- )
-||#
(defmethod shared-initialize :after
((class std-class)
(setq direct-slots
(if direct-slots-p
(setf (slot-value class 'direct-slots)
- (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
+ (mapcar (lambda (pl) (make-direct-slotd class pl))
+ direct-slots))
(slot-value class 'direct-slots)))
(if direct-default-initargs-p
- (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
- (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
+ (setf (plist-value class 'direct-default-initargs)
+ direct-default-initargs)
+ (setq direct-default-initargs
+ (plist-value class 'direct-default-initargs)))
(setf (plist-value class 'class-slot-cells)
(gathering1 (collecting)
(dolist (dslotd direct-slots)
(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-name (class-name
+ class))))))
(add-direct-subclasses class direct-superclasses)
(update-class class nil)
(make-class-predicate class predicate-name)
#'(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+ slot-names &key)
+ (declare (ignore slot-names))
+ (with-slots (allocation class)
+ slotd
+ (setq allocation (if (eq allocation :class) class allocation))))
+
+(defmethod shared-initialize :after ((slotd structure-slot-definition)
+ slot-names
+ &key (allocation :instance))
+ (declare (ignore slot-names))
+ (unless (eq allocation :instance)
+ (error "Structure slots must have :INSTANCE allocation.")))
+
+(defun make-structure-class-defstruct-form
+ (name direct-slots include)
+ (let* ((conc-name (intern (format nil "~S structure class " name)))
+ (constructor (intern (format nil "~A constructor" conc-name)))
+ (defstruct `(defstruct (,name
+ ,@(when include
+ `((:include ,(class-name include))))
+ (:print-function print-std-instance)
+ (:predicate nil)
+ (:conc-name ,conc-name)
+ (:constructor ,constructor ())
+ (:copier nil))
+ ,@(mapcar (lambda (slot)
+ `(,(slot-definition-name slot)
+ +slot-unbound+))
+ direct-slots)))
+ (reader-names (mapcar (lambda (slotd)
+ (intern (format nil
+ "~A~A reader"
+ conc-name
+ (slot-definition-name
+ slotd))))
+ direct-slots))
+ (writer-names (mapcar (lambda (slotd)
+ (intern (format nil
+ "~A~A writer"
+ conc-name
+ (slot-definition-name
+ slotd))))
+ direct-slots))
+ (readers-init
+ (mapcar (lambda (slotd reader-name)
+ (let ((accessor
+ (slot-definition-defstruct-accessor-symbol
+ slotd)))
+ `(defun ,reader-name (obj)
+ (declare (type ,name obj))
+ (,accessor obj))))
+ direct-slots reader-names))
+ (writers-init
+ (mapcar (lambda (slotd writer-name)
+ (let ((accessor
+ (slot-definition-defstruct-accessor-symbol
+ slotd)))
+ `(defun ,writer-name (nv obj)
+ (declare (type ,name obj))
+ (setf (,accessor obj) nv))))
+ direct-slots writer-names))
+ (defstruct-form
+ `(progn
+ ,defstruct
+ ,@readers-init ,@writers-init
+ (cons nil nil))))
+ (values defstruct-form constructor reader-names writer-names)))
+
(defmethod shared-initialize :after
((class structure-class)
slot-names
(mapcar #'(lambda (pl)
(when defstruct-p
(let* ((slot-name (getf pl :name))
- (acc-name (format nil "~S structure class ~A"
- name slot-name))
+ (acc-name
+ (format nil
+ "~S structure class ~A"
+ name slot-name))
(accessor (intern acc-name)))
- (setq pl (list* :defstruct-accessor-symbol accessor
- pl))))
+ (setq pl (list* :defstruct-accessor-symbol
+ accessor pl))))
(make-direct-slotd class pl))
direct-slots)))
(setq direct-slots (slot-value class 'direct-slots)))
(when defstruct-p
- (let* ((include (car (slot-value class 'direct-superclasses)))
- (conc-name (intern (format nil "~S structure class " name)))
- (constructor (intern (format nil "~A constructor" conc-name)))
- (defstruct `(defstruct (,name
- ,@(when include
- `((:include ,(class-name include))))
- (:print-function print-std-instance)
- (:predicate nil)
- (:conc-name ,conc-name)
- (:constructor ,constructor ()))
- ,@(mapcar #'(lambda (slot)
- `(,(slot-definition-name slot)
- +slot-unbound+))
- direct-slots)))
- (reader-names (mapcar (lambda (slotd)
- (intern (format nil
- "~A~A reader"
- conc-name
- (slot-definition-name
- slotd))))
- direct-slots))
- (writer-names (mapcar (lambda (slotd)
- (intern (format nil
- "~A~A writer"
- conc-name
- (slot-definition-name
- slotd))))
- direct-slots))
- (readers-init
- (mapcar (lambda (slotd reader-name)
- (let ((accessor
- (slot-definition-defstruct-accessor-symbol
- slotd)))
- `(defun ,reader-name (obj)
- (declare (type ,name obj))
- (,accessor obj))))
- direct-slots reader-names))
- (writers-init
- (mapcar (lambda (slotd writer-name)
- (let ((accessor
- (slot-definition-defstruct-accessor-symbol
- slotd)))
- `(defun ,writer-name (nv obj)
- (declare (type ,name obj))
- (setf (,accessor obj) nv))))
- direct-slots writer-names))
- (defstruct-form
- `(progn
- ,defstruct
- ,@readers-init ,@writers-init
- (declare-structure ',name nil nil))))
- (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)
- (gdefinition writer-name))))
- (setf (slot-value dslotd 'internal-reader-function)
- reader)
- (setf (slot-value dslotd 'internal-writer-function)
- writer)))
- direct-slots reader-names writer-names)
- (setf (slot-value class 'defstruct-form) defstruct-form)
- (setf (slot-value class 'defstruct-constructor) constructor))))
- (add-direct-subclasses class direct-superclasses)
- (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)))
- (update-pv-table-cache-info class)
- (setq predicate-name (if predicate-name-p
+ (let ((include (car (slot-value class 'direct-superclasses))))
+ (multiple-value-bind (defstruct-form constructor reader-names writer-names)
+ (make-structure-class-defstruct-form name direct-slots include)
+ (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)
+ (gdefinition writer-name))))
+ (setf (slot-value dslotd 'internal-reader-function)
+ reader)
+ (setf (slot-value dslotd 'internal-writer-function)
+ writer)))
+ direct-slots reader-names writer-names)
+ (setf (slot-value class 'defstruct-form) defstruct-form)
+ (setf (slot-value class 'defstruct-constructor) constructor))))
+ (add-direct-subclasses class direct-superclasses)
+ (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)))
+ (update-pv-table-cache-info class)
+ (setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
- (car 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))
-
+ (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) initargs)
(declare (ignore initargs))
(find-class 'structure-direct-slot-definition))
;; If there is a change in the shape of the instances then the
;; old class is now obsolete.
(let* ((nlayout (mapcar #'slot-definition-name
- (sort instance-slots #'< :key #'slot-definition-location)))
+ (sort instance-slots #'<
+ :key #'slot-definition-location)))
(nslots (length nlayout))
(nwrapper-class-slots (compute-class-slots class-slots))
(owrapper (class-wrapper class))
(when (and (class-finalized-p class)
(let ((cpl (class-precedence-list class)))
(or (member *the-class-slot-class* cpl)
- (member *the-class-standard-effective-slot-definition* cpl))))
+ (member *the-class-standard-effective-slot-definition*
+ cpl))))
(let ((gf-table (make-hash-table :test 'eq)))
(labels ((collect-gfs (class)
(dolist (gf (specializer-direct-generic-functions class))
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)
+ (setq type (cond ((eq type t) slotd-type)
((*subtypep type slotd-type) type)
(t `(and ,type ,slotd-type)))))))
(list :name name
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
(let ((slotd (car direct-slotds)))
- (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
- :internal-reader-function (slot-definition-internal-reader-function slotd)
- :internal-writer-function (slot-definition-internal-writer-function slotd)
+ (list* :defstruct-accessor-symbol
+ (slot-definition-defstruct-accessor-symbol slotd)
+ :internal-reader-function
+ (slot-definition-internal-reader-function slotd)
+ :internal-writer-function
+ (slot-definition-internal-writer-function slotd)
(call-next-method))))
\f
-;;; NOTE: For bootstrapping considerations, these can't use make-instance
+;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
;;; to make the method object. They have to use make-a-method which
;;; is a specially bootstrapped mechanism for making standard methods.
(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
;;; *** There is a subtle bug here which is going to have to be fixed.
;;; *** Namely, the simplistic use of the template has to be fixed. We
;;; *** have to give the optimize-slot-value method the user might have
-;;; *** defined for this metclass a chance to run.
+;;; *** defined for this metaclass a chance to run.
(defmethod make-reader-method-function ((class slot-class) slot-name)
(make-std-reader-method-function (class-name class) slot-name))
(make-std-boundp-method-function (class-name class) slot-name))
\f
;;;; inform-type-system-about-class
-;;;; make-type-predicate
;;;
-;;; These are NOT part of the standard protocol. They are internal mechanism
-;;; which PCL uses to *try* and tell the type system about class definitions.
-;;; In a more fully integrated implementation of CLOS, the type system would
-;;; know about class objects and class names in a more fundamental way and
-;;; the mechanism used to inform the type system about new classes would be
-;;; different.
+;;; These are NOT part of the standard protocol. They are internal
+;;; mechanism which PCL uses to *try* and tell the type system about
+;;; class definitions. In a more fully integrated implementation of
+;;; CLOS, the type system would know about class objects and class
+;;; names in a more fundamental way and the mechanism used to inform
+;;; the type system about new classes would be different.
(defmethod inform-type-system-about-class ((class std-class) name)
(inform-type-system-about-std-class name))
+
+(defmethod inform-type-system-about-class ((class structure-class) (name t))
+ nil)
\f
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
;; will already be doing what we want. In particular, we must be
;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
;; means do what FLUSH does and then some.
- (when (eq state 't) ; FIXME: should be done through INVALID-WRAPPER-P
+ (when (eq state t) ; FIXME: should be done through INVALID-WRAPPER-P
(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))
- (without-interrupts
+ (sb-sys:without-interrupts
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(invalidate-wrapper owrapper ':flush nwrapper))))))
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
- (without-interrupts
+ (sb-sys:without-interrupts
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(invalidate-wrapper owrapper ':obsolete nwrapper)
;;; - when the instance is involved in method lookup
;;; - when attempting to access a slot of an instance
;;;
-;;; It is not called by class-of, wrapper-of, or any of the low-level instance
-;;; access macros.
+;;; It is not called by class-of, wrapper-of, or any of the low-level
+;;; instance access macros.
;;;
-;;; Of course these times when it is called are an internal implementation
-;;; detail of PCL and are not part of the documented description of when the
-;;; obsolete instance update happens. The documented description is as it
-;;; appears in 88-002R.
+;;; Of course these times when it is called are an internal
+;;; implementation detail of PCL and are not part of the documented
+;;; description of when the obsolete instance update happens. The
+;;; documented description is as it appears in 88-002R.
;;;
-;;; This has to return the new wrapper, so it counts on all the methods on
-;;; obsolete-instance-trap-internal to return the new wrapper. It also does
-;;; a little internal error checking to make sure that the traps are only
-;;; happening when they should, and that the trap methods are computing
-;;; appropriate new wrappers.
+;;; This has to return the new wrapper, so it counts on all the
+;;; methods on obsolete-instance-trap-internal to return the new
+;;; wrapper. It also does a little internal error checking to make
+;;; sure that the traps are only happening when they should, and that
+;;; the trap methods are computing appropriate new wrappers.
;;; obsolete-instance-trap might be called on structure instances
;;; after a structure is redefined. In most cases, obsolete-instance-trap
(lambda (condition stream)
;; Don't try to print the structure, since it probably won't work.
(format stream
- "obsolete structure error in ~S:~@
- for a structure of type: ~S"
- (sb-kernel::condition-function-name condition)
+ "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
(type-of (obsolete-structure-datum condition))))))
(defun obsolete-instance-trap (owrapper nwrapper instance)
(opos (interval :from 0)))
(let ((npos (posq name nlayout)))
(if npos
- (setf (instance-ref nslots npos) (instance-ref oslots opos))
+ (setf (clos-slots-ref nslots npos)
+ (clos-slots-ref oslots opos))
(progn
(push name discarded)
- (unless (eq (instance-ref oslots opos) +slot-unbound+)
- (setf (getf plist name) (instance-ref oslots opos)))))))
+ (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
+ (setf (getf plist name) (clos-slots-ref oslots opos)))))))
;; Go through all the old shared slots.
(iterate ((oclass-slot-and-val (list-elements oclass-slots)))
(val (cdr oclass-slot-and-val)))
(let ((npos (posq name nlayout)))
(if npos
- (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
+ (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val))
(progn (push name discarded)
(unless (eq val +slot-unbound+)
(setf (getf plist name) val)))))))
(new-position (interval :from 0)))
(let ((old-position (posq new-slot old-layout)))
(when old-position
- (setf (instance-ref new-slots new-position)
- (instance-ref old-slots old-position)))))
+ (setf (clos-slots-ref new-slots new-position)
+ (clos-slots-ref old-slots old-position)))))
;; "The values of slots specified as shared in the class CFROM and
;; as local in the class CTO are retained."
(iterate ((slot-and-val (list-elements old-class-slots)))
(let ((position (posq (car slot-and-val) new-layout)))
(when position
- (setf (instance-ref new-slots position) (cdr slot-and-val)))))
+ (setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
;; Make the copy point to the old instance's storage, and make the
;; old instance point to the new storage.
\f
(defmethod validate-superclass ((c slot-class)
(f forward-referenced-class))
- 't)
+ t)
\f
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
(pushnew dependent (plist-value metaobject 'dependents)))