(defmacro early-gf-methods (gf)
`(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+(defun safe-generic-function-methods (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
+ (generic-function-methods generic-function)))
+
(defvar *sgf-arg-info-index*
(!bootstrap-slot-index 'standard-generic-function 'arg-info))
~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))))
+
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(let* ((existing-p (and methods (cdr methods) new-method))
(nreq (length (arg-info-metatypes arg-info)))
(dolist (method (if new-method (list new-method) methods))
(let* ((specializers (if (or (eq *boot-state* 'complete)
(not (consp method)))
- (method-specializers method)
+ (safe-method-specializers method)
(early-method-specializers method t)))
(class (if (or (eq *boot-state* 'complete) (not (consp method)))
(class-of method)
(set-arg-info fin :lambda-list lambda-list))))
fin))
+(defun safe-gf-dfun-state (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
+ (gf-dfun-state generic-function)))
+(defun (setf safe-gf-dfun-state) (new-value generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (setf (clos-slots-ref (get-slots generic-function)
+ *sgf-dfun-state-index*)
+ new-value)
+ (setf (gf-dfun-state generic-function) new-value)))
+
(defun set-dfun (gf &optional dfun cache info)
(when cache
(setf (cache-owner cache) gf))
(list* dfun cache info)
dfun)))
(if (eq *boot-state* 'complete)
- (if (eq (class-of gf) *the-class-standard-generic-function*)
- ;; break metacircles: see sbcl-devel 2006-01-15 and #lisp
- ;; IRC logs 2006-01-16 for the hilarity.
- (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
- new-state)
- (setf (gf-dfun-state gf) new-state))
+ (setf (safe-gf-dfun-state gf) new-state)
(setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
new-state)))
dfun)
(defun gf-dfun-cache (gf)
(let ((state (if (eq *boot-state* 'complete)
- (if (eq (class-of gf) *the-class-standard-generic-function*)
- (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
- (gf-dfun-state gf))
+ (safe-gf-dfun-state gf)
(clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(defun gf-dfun-info (gf)
(let ((state (if (eq *boot-state* 'complete)
- (if (eq (class-of gf) *the-class-standard-generic-function*)
- (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
- (gf-dfun-state gf))
+ (safe-gf-dfun-state gf)
(clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(when lambda-list-p
(proclaim (defgeneric-declaration fun-name lambda-list)))))
\f
+(defun safe-gf-arg-info (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (fsc-instance-slots generic-function)
+ *sgf-arg-info-index*)
+ (gf-arg-info generic-function)))
+
;;; FIXME: this function took on a slightly greater role than it
;;; previously had around 2005-11-02, when CSR fixed the bug whereby
;;; having more than one subclass of standard-generic-function caused
(multiple-value-bind (applyp metatypes arg-info)
(let* ((arg-info (if (early-gf-p gf)
(early-gf-arg-info gf)
- (if (eq (class-of gf) *the-class-standard-generic-function*)
- (clos-slots-ref (fsc-instance-slots gf) *sgf-arg-info-index*)
- (gf-arg-info gf))))
+ (safe-gf-arg-info gf)))
(metatypes (arg-info-metatypes arg-info)))
(values (arg-info-applyp arg-info)
metatypes
(some (lambda (method)
(let ((fmf (if (listp method)
(third method)
- (method-fast-function method))))
+ (safe-method-fast-function method))))
(method-function-get fmf :slot-name-lists)))
;; KLUDGE: As of sbcl-0.6.4, it's very important for
;; efficiency to know the type of the sequence argument to
(dolist (method methods t)
(when (eq *boot-state* 'complete)
(when (or (some #'eql-specializer-p
- (method-specializers method))
- (method-qualifiers method))
+ (safe-method-specializers method))
+ (safe-method-qualifiers method))
(return nil)))
(let ((value (method-function-get
(if early-p
(or (third method) (second method))
- (or (method-fast-function method)
- (method-function method)))
+ (or (safe-method-fast-function method)
+ (safe-method-function method)))
:constant-value default)))
(when (or (eq value default)
(and boolean-values-p
(let ((definite-p t) (possibly-applicable-methods nil))
(dolist (method (if (early-gf-p generic-function)
(early-gf-methods generic-function)
- (if (eq (class-of generic-function)
- *the-class-standard-generic-function*)
- ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO
- (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*)
- (generic-function-methods generic-function))))
+ (safe-generic-function-methods generic-function)))
(let ((specls (if (consp method)
(early-method-specializers method t)
- (method-specializers method)))
+ (safe-method-specializers method)))
(types types)
(possibly-applicable-p t) (applicable-p t))
(dolist (specl specls)
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; this file attempts to test possible metacircularity issues arising
+;;; from adding slots to methods in odd places.
+
+(defpackage "MOP-12"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-12")
+
+(defclass super-method ()
+ ((abc :accessor abc :initarg :abc)))
+
+;;; Test case reported by Jean Bresson sbcl-devel 2006-02-09
+(defclass sub-generic-function1 (standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+
+(defclass sub-method1 (standard-method super-method) ())
+
+(defgeneric myfun1 (a b)
+ (:generic-function-class sub-generic-function1)
+ (:method-class sub-method1))
+
+(defvar *count1* 0)
+
+(defmethod myfun1 (a b)
+ (incf *count1*))
+
+(myfun1 2 3)
+(assert (= *count1* 1))
+(myfun1 t nil)
+(assert (= *count1* 2))
+
+(defmethod myfun1 ((a integer) (b integer))
+ (incf *count1* 2))
+
+(myfun1 2 3)
+(assert (= *count1* 4))
+(myfun1 t nil)
+(assert (= *count1* 5))
+
+;;; Friendlier superclass order test case from Pascal Costanza
+;;; sbcl-devel 2006-02-09
+(defclass sub-generic-function2 (standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+
+(defclass sub-method2 (super-method standard-method) ())
+
+(defgeneric myfun2 (a b)
+ (:generic-function-class sub-generic-function2)
+ (:method-class sub-method2))
+
+(defvar *count2* 0)
+
+(defmethod myfun2 (a b)
+ (incf *count2*))
+
+(myfun2 2 3)
+(assert (= *count2* 1))
+(myfun2 t nil)
+(assert (= *count2* 2))
+
+(defmethod myfun2 ((a integer) (b integer))
+ (incf *count2* 2))
+
+(myfun2 2 3)
+(assert (= *count2* 4))
+(myfun2 t nil)
+(assert (= *count2* 5))
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; this file attempts to test possible metacircularity issues arising
+;;; from adding slots to generic functions in odd places.
+
+(defpackage "MOP-13"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-13")
+
+(defclass super-funcallable-mixin ()
+ ((abc :accessor abc :initarg :abc))
+ (:metaclass funcallable-standard-class))
+
+(defclass sub-generic-function1 (standard-generic-function
+ super-funcallable-mixin) ()
+ (:metaclass funcallable-standard-class))
+
+(defclass sub-method1 (standard-method) ())
+
+(defgeneric myfun1 (a b)
+ (:generic-function-class sub-generic-function1)
+ (:method-class sub-method1))
+
+(defvar *count1* 0)
+
+(defmethod myfun1 (a b)
+ (incf *count1*))
+
+(myfun1 2 3)
+(assert (= *count1* 1))
+(myfun1 t nil)
+(assert (= *count1* 2))
+
+(defmethod myfun1 ((a integer) (b integer))
+ (incf *count1* 2))
+
+(myfun1 2 3)
+(assert (= *count1* 4))
+(myfun1 t nil)
+(assert (= *count1* 5))
+
+;;; Friendlier superclass order test case
+(defclass sub-generic-function2 (super-funcallable-mixin
+ standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+
+(defclass sub-method2 (standard-method) ())
+
+(defgeneric myfun2 (a b)
+ (:generic-function-class sub-generic-function2)
+ (:method-class sub-method2))
+
+(defvar *count2* 0)
+
+(defmethod myfun2 (a b)
+ (incf *count2*))
+
+(myfun2 2 3)
+(assert (= *count2* 1))
+(myfun2 t nil)
+(assert (= *count2* 2))
+
+(defmethod myfun2 ((a integer) (b integer))
+ (incf *count2* 2))
+
+(myfun2 2 3)
+(assert (= *count2* 4))
+(myfun2 t nil)
+(assert (= *count2* 5))
projects / sbcl.git / commitdiff