- (gf-nopt (arg-info-number-optional arg-info))
- (gf-key/rest-p (arg-info-key/rest-p arg-info))
- (gf-keywords (arg-info-keys arg-info)))
- (unless (= nreq gf-nreq)
- (lose
- "the method has ~A required arguments than the generic function."
- (comparison-description nreq gf-nreq)))
- (unless (= nopt gf-nopt)
- (lose
- "the method has ~A optional arguments than the generic function."
- (comparison-description nopt gf-nopt)))
- (unless (eq (or keysp restp) gf-key/rest-p)
- (lose
- "the method and generic function differ in whether they accept~_~
- &REST or &KEY arguments."))
- (when (consp gf-keywords)
- (unless (or (and restp (not keysp))
- allow-other-keys-p
- (every (lambda (k) (memq k keywords)) gf-keywords))
- (lose "the method does not accept each of the &KEY arguments~2I~_~
- ~S."
- gf-keywords)))))))
+ (gf-nopt (arg-info-number-optional arg-info))
+ (gf-key/rest-p (arg-info-key/rest-p arg-info))
+ (gf-keywords (arg-info-keys arg-info)))
+ (unless (= nreq gf-nreq)
+ (lose
+ "the method has ~A required arguments than the generic function."
+ (comparison-description nreq gf-nreq)))
+ (unless (= nopt gf-nopt)
+ (lose
+ "the method has ~A optional arguments than the generic function."
+ (comparison-description nopt gf-nopt)))
+ (unless (eq (or keysp restp) gf-key/rest-p)
+ (lose
+ "the method and generic function differ in whether they accept~_~
+ &REST or &KEY arguments."))
+ (when (consp gf-keywords)
+ (unless (or (and restp (not keysp))
+ allow-other-keys-p
+ (every (lambda (k) (memq k keywords)) gf-keywords))
+ (lose "the method does not accept each of the &KEY arguments~2I~_~
+ ~S."
+ gf-keywords)))))))
+
+(defvar *sm-specializers-index*
+ (!bootstrap-slot-index 'standard-method 'specializers))
+(defvar *sm-fast-function-index*
+ (!bootstrap-slot-index 'standard-method 'fast-function))
+(defvar *sm-function-index*
+ (!bootstrap-slot-index 'standard-method 'function))
+(defvar *sm-plist-index*
+ (!bootstrap-slot-index 'standard-method 'plist))
+
+;;; FIXME: we don't actually need this; we could test for the exact
+;;; class and deal with it as appropriate. In fact we probably don't
+;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
+;;; the standard reader method for METHOD-SPECIALIZERS. Probably.
+(dolist (s '(specializers fast-function function plist))
+ (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
+ (!bootstrap-slot-index 'standard-reader-method s)
+ (!bootstrap-slot-index 'standard-writer-method s)
+ (!bootstrap-slot-index 'standard-boundp-method s))))
+
+(defun safe-method-specializers (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (clos-slots-ref (get-slots method) *sm-specializers-index*)
+ (method-specializers method))))
+(defun safe-method-fast-function (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (clos-slots-ref (get-slots method) *sm-fast-function-index*)
+ (method-fast-function method))))
+(defun safe-method-function (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (clos-slots-ref (get-slots method) *sm-function-index*)
+ (method-function method))))
+(defun safe-method-qualifiers (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*)))
+ (getf plist 'qualifiers))
+ (method-qualifiers method))))