(set-slot 'direct-slots direct-slots)
(set-slot 'slots slots)
(set-slot 'initialize-info nil))
+
+ ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
+ ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
+ ;; matter here for the slot DIRECT-SUBCLASSES, since every class
+ ;; inherits the slot from class CLASS.
+ (dolist (super direct-supers)
+ (let* ((super (find-class super))
+ (subclasses (!bootstrap-get-slot metaclass-name super
+ 'direct-subclasses)))
+ (cond ((eq +slot-unbound+ subclasses)
+ (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+ (list class)))
+ ((not (memq class subclasses))
+ (!bootstrap-set-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
(!bootstrap-accessor-definitions1
'slot-object
slot-name
- (list (slot-reader-symbol slot-name))
- (list (slot-writer-symbol slot-name))
- (list (slot-boundp-symbol slot-name)))))))))))
+ (list (slot-reader-name slot-name))
+ (list (slot-writer-name slot-name))
+ (list (slot-boundp-name slot-name)))))))))))
(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
generic-function
method
args))
+
+;;; An extension to the ANSI standard: in the presence of e.g. a
+;;; :BEFORE method, it would seem that going through
+;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an
+;;; applicable method. -- CSR, 2002-11-15
+(defmethod no-primary-method (generic-function &rest args)
+ (error "~@<There is no primary method for the generic function ~2I~_~S~
+ ~I~_when called with arguments ~2I~_~S.~:>"
+ generic-function
+ args))