;;;; various class accessors that are a little more complicated than can be
;;;; done with automatically generated reader methods
-(defmethod class-prototype ((class std-class))
- (with-slots (prototype) class
- (or prototype (setq prototype (allocate-instance class)))))
-
-(defmethod class-prototype ((class structure-class))
- (with-slots (prototype wrapper defstruct-constructor) class
- (or prototype
- (setq prototype
- (if defstruct-constructor
- (allocate-instance class)
- (allocate-standard-instance wrapper))))))
-
-(defmethod class-prototype ((class condition-class))
- (with-slots (prototype) class
- (or prototype (setf prototype (allocate-instance class)))))
+(defmethod class-prototype :before (class)
+ (unless (class-finalized-p class)
+ (error "~S not yet finalized, cannot allocate a prototype." class)))
+
+;;; KLUDGE: For some reason factoring the common body into a function
+;;; breaks PCL bootstrapping, so just generate it with a macrolet for
+;;; all.
+(macrolet ((def (class)
+ `(defmethod class-prototype ((class ,class))
+ (with-slots (prototype) class
+ (or prototype
+ (setf prototype (allocate-instance class)))))))
+ (def std-class)
+ (def condition-class)
+ (def structure-class))
(defmethod class-direct-default-initargs ((class slot-class))
(plist-value class 'direct-default-initargs))
(setf (info :type :translator specl)
(constantly (make-member-type :members (list (specializer-object specl))))))
-\f
-(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
- :definition-source `((defclass ,name)
- ,*load-pathname*)
- other)))
- res))
+(defun real-load-defclass (name metaclass-name supers slots other
+ readers writers slot-names)
+ (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*)
+ other)))
+ res)))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
args))
(defmethod ensure-class-using-class ((class null) name &rest args &key)
- (without-package-locks
- (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)))
+ (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))
+ (without-package-locks
+ (setf (find-class name) class))
+ (set-class-type-translation class name)
+ class))
(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
- (without-package-locks
- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (unless (eq (class-of class) meta)
- (apply #'change-class class meta initargs))
- (apply #'reinitialize-instance class initargs)
- (setf (find-class name) class)
- (set-class-type-translation class name)
- class)))
+ (multiple-value-bind (meta initargs)
+ (ensure-class-values class args)
+ (unless (eq (class-of class) meta)
+ (apply #'change-class class meta initargs))
+ (apply #'reinitialize-instance class initargs)
+ (without-package-locks
+ (setf (find-class name) class))
+ (set-class-type-translation class name)
+ class))
(defmethod class-predicate-name ((class t))
'constantly-nil)
(make-instance 'forward-referenced-class
:name s)))))
-(defun ensure-class-values (class args)
- (let* ((initargs (copy-list args))
- (unsupplied (list 1))
- (supplied-meta (getf initargs :metaclass unsupplied))
- (supplied-supers (getf initargs :direct-superclasses unsupplied))
- (supplied-slots (getf initargs :direct-slots unsupplied))
- (meta
- (cond ((neq supplied-meta unsupplied)
- (find-class supplied-meta))
- ((or (null class)
- (forward-referenced-class-p class))
- *the-class-standard-class*)
- (t
- (class-of class)))))
- ;; KLUDGE: It seemed to me initially that there ought to be a way
- ;; of collecting all the erroneous problems in one go, rather than
- ;; this way of solving the problem of signalling the errors that
- ;; we are required to, which stops at the first bogus input.
- ;; However, after playing around a little, I couldn't find that
- ;; way, so I've left it as is, but if someone does come up with a
- ;; better way... -- CSR, 2002-09-08
- (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
- ((endp direct-slots) nil)
- (destructuring-bind (slot &rest more) direct-slots
- (let ((slot-name (getf slot :name)))
- (when (some (lambda (s) (eq slot-name (getf s :name))) more)
- ;; FIXME: It's quite possible that we ought to define an
- ;; SB-INT:PROGRAM-ERROR function to signal these and other
- ;; errors throughout the codebase that are required to be
- ;; of type PROGRAM-ERROR.
- (error 'simple-program-error
- :format-control "~@<There is more than one direct slot ~
- with name ~S.~:>"
- :format-arguments (list slot-name)))
- (do ((stuff slot (cddr stuff)))
- ((endp stuff) nil)
- (destructuring-bind (option value &rest more) stuff
- (cond
- ((and (member option '(:allocation :type
- :initform :documentation))
- (not (eq unsupplied
- (getf more option unsupplied))))
- (error 'simple-program-error
- :format-control "~@<Duplicate slot option ~S for ~
- slot named ~S.~:>"
- :format-arguments (list option slot-name)))
- ((and (eq option :readers)
- (notevery #'symbolp value))
- (error 'simple-program-error
- :format-control "~@<Slot reader names for slot ~
- named ~S must be symbols.~:>"
- :format-arguments (list slot-name)))
- ((and (eq option :initargs)
- (notevery #'symbolp value))
- (error 'simple-program-error
- :format-control "~@<Slot initarg names for slot ~
- named ~S must be symbols.~:>"
- :format-arguments (list slot-name)))))))))
- (loop for (initarg . more) on (getf initargs :direct-default-initargs)
- for name = (car initarg)
- when (some (lambda (a) (eq (car a) name)) more)
- do (error 'simple-program-error
- :format-control "~@<Duplicate initialization argument ~
- name ~S in :DEFAULT-INITARGS.~:>"
- :format-arguments (list name class)))
- (let ((metaclass 0)
- (default-initargs 0))
- (do ((args initargs (cddr args)))
- ((endp args) nil)
- (case (car args)
- (:metaclass
- (when (> (incf metaclass) 1)
- (error 'simple-program-error
- :format-control "~@<More than one :METACLASS ~
- option specified.~:>")))
- (:direct-default-initargs
- (when (> (incf default-initargs) 1)
- (error 'simple-program-error
- :format-control "~@<More than one :DEFAULT-INITARGS ~
- option specified.~:>"))))))
- (remf initargs :metaclass)
- (loop (unless (remf initargs :direct-superclasses) (return)))
- (loop (unless (remf initargs :direct-slots) (return)))
- (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))))
+(defun ensure-class-values (class initargs)
+ (let (metaclass metaclassp reversed-plist)
+ (doplist (key val) initargs
+ (cond ((eq key :metaclass)
+ (setf metaclass val
+ metaclassp key))
+ (t
+ (when (eq key :direct-superclasses)
+ (setf val (mapcar #'fix-super val)))
+ (setf reversed-plist (list* val key reversed-plist)))))
+ (values (cond (metaclassp
+ (if (classp metaclass)
+ metaclass
+ (find-class metaclass)))
+ ((or (null class) (forward-referenced-class-p class))
+ *the-class-standard-class*)
+ (t
+ (class-of class)))
+ (nreverse reversed-plist))))
+
\f
(defmethod shared-initialize :after
((class std-class)
(setf (slot-value class 'class-eq-specializer)
(make-instance 'class-eq-specializer :class class)))
-(defmethod reinitialize-instance :before ((class slot-class) &key)
- (remove-direct-subclasses class (class-direct-superclasses class))
+(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses)
+ (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))
+ (remove-direct-subclass old-super class))
(remove-slot-accessors class (class-direct-slots class)))
(defmethod reinitialize-instance :after ((class slot-class)
(fix-slot-accessors class dslotds 'remove))
(defun fix-slot-accessors (class dslotds add/remove)
- ;; We disable package locks here, since defining a class can trigger
- ;; the update of the accessors of another class -- which might lead
- ;; to package lock violations if we didn't.
- (without-package-locks
- (flet ((fix (gfspec name r/w)
- (let* ((ll (case r/w (r '(object)) (w '(new-value object))))
- (gf (if (fboundp gfspec)
- (ensure-generic-function gfspec)
- (ensure-generic-function gfspec :lambda-list ll))))
- (case r/w
- (r (if (eq add/remove 'add)
- (add-reader-method class gf name)
- (remove-reader-method class gf)))
- (w (if (eq add/remove 'add)
- (add-writer-method class gf name)
- (remove-writer-method class gf)))))))
- (dolist (dslotd dslotds)
- (let ((slot-name (slot-definition-name dslotd)))
- (dolist (r (slot-definition-readers dslotd))
- (fix r slot-name 'r))
- (dolist (w (slot-definition-writers dslotd))
- (fix w slot-name 'w)))))))
+ (flet ((fix (gfspec name r/w)
+ (let ((gf (cond ((eq add/remove 'add)
+ (if (fboundp gfspec)
+ (without-package-locks
+ (ensure-generic-function gfspec))
+ (ensure-generic-function
+ gfspec :lambda-list (case r/w
+ (r '(object))
+ (w '(new-value object))))))
+ ((generic-function-p (and (fboundp gfspec)
+ (fdefinition gfspec)))
+ (without-package-locks
+ (ensure-generic-function gfspec))))))
+ (when gf
+ (case r/w
+ (r (if (eq add/remove 'add)
+ (add-reader-method class gf name)
+ (remove-reader-method class gf)))
+ (w (if (eq add/remove 'add)
+ (add-writer-method class gf name)
+ (remove-writer-method class gf))))))))
+ (dolist (dslotd dslotds)
+ (let ((slot-name (slot-definition-name dslotd)))
+ (dolist (r (slot-definition-readers dslotd))
+ (fix r slot-name 'r))
+ (dolist (w (slot-definition-writers dslotd))
+ (fix w slot-name 'w))))))
\f
(defun add-direct-subclasses (class supers)
(dolist (super supers)
(unless (memq class (class-direct-subclasses class))
(add-direct-subclass super class))))
-(defun remove-direct-subclasses (class supers)
- (let ((old (class-direct-superclasses class)))
- (dolist (o (set-difference old supers))
- (remove-direct-subclass o class))))
-\f
(defmethod finalize-inheritance ((class std-class))
(update-class class t))
(find-class 'standard-direct-slot-definition))
(defun make-direct-slotd (class initargs)
- (let ((initargs (list* :class class initargs)))
- (apply #'make-instance
- (apply #'direct-slot-definition-class class initargs)
- initargs)))
-
+ (apply #'make-instance
+ (apply #'direct-slot-definition-class class initargs)
+ :class class
+ initargs))
+
+;;; I (CSR) am not sure, but I believe that the particular order of
+;;; slots is quite important: it is ideal to attempt to have a
+;;; constant slot location for the same notional slots as much as
+;;; possible, so that clever discriminating functions (ONE-INDEX et
+;;; al.) have a chance of working. The below at least walks through
+;;; the slots predictably, but maybe it would be good to compute some
+;;; kind of optimal slot layout by looking at locations of slots in
+;;; superclasses?
(defmethod compute-slots ((class std-class))
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
;; for each different slot name we find in our superclasses. Each
;; call receives the class and a list of the dslotds with that name.
;; The list is in most-specific-first order.
(let ((name-dslotds-alist ()))
- (dolist (c (class-precedence-list class))
+ (dolist (c (reverse (class-precedence-list class)))
(dolist (slot (class-direct-slots c))
(let* ((name (slot-definition-name slot))
(entry (assq name name-dslotds-alist)))
(mapcar (lambda (direct)
(compute-effective-slot-definition class
(car direct)
- (nreverse (cdr direct))))
- name-dslotds-alist)))
+ (cdr direct)))
+ (nreverse name-dslotds-alist))))
(defmethod compute-slots ((class standard-class))
(call-next-method))
(defmethod class-default-initargs ((class built-in-class)) ())
(defmethod validate-superclass ((c class) (s built-in-class))
- (or (eq s *the-class-t*)
- (eq s *the-class-stream*)))
+ (or (eq s *the-class-t*) (eq s *the-class-stream*)
+ ;; FIXME: bad things happen if someone tries to mix in both
+ ;; FILE-STREAM and STRING-STREAM (as they have the same
+ ;; layout-depthoid). Is there any way we can provide a useful
+ ;; error message? -- CSR, 2005-05-03
+ (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)))
\f
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())
projects / sbcl.git / blobdiff