From: Christophe Rhodes Date: Fri, 10 Feb 2006 15:02:10 +0000 (+0000) Subject: 0.9.9.25: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=47bf3e24a52a2687bd8f07c4674cb9e81163085d;p=sbcl.git 0.9.9.25: Fix bug in method-metacircle/discriminating function update. ... start defining SAFE-FOO variants of method- and generic-function- accessors, concentrating the horribleness. At the moment, we have separate SAFE-FOO and EARLY-FOO logic; at some time in the future it might be worth coalescing the two. ... test cases. Include both Jean and Pascal's variants of the method code, and write similar generic-function code (which, admittedly, seemed to pass anyway). --- diff --git a/NEWS b/NEWS index 29541ac..3b59dcb 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,9 @@ changes in sbcl-0.9.10 relative to sbcl-0.9.9: applicable non-standard primary or :AROUND method on INITIALIZE-INSTANCE or SHARED-INITIALIZE and a non-keyword initarg no longer cause unbound variable errors. (reported by Kevin Reid) + * fixed bug: metacircle resolution in cases where methods have slots + added before the slots from STANDARD-METHOD. (reported by Jean + Bresson) changes in sbcl-0.9.9 relative to sbcl-0.9.8: * new platform: experimental support for the Windows operating diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e87e2ee..fc939a6 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1636,6 +1636,11 @@ bootstrapping. (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)) @@ -1770,6 +1775,67 @@ bootstrapping. ~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))) @@ -1783,7 +1849,7 @@ bootstrapping. (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) @@ -1915,6 +1981,17 @@ bootstrapping. (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)) @@ -1922,21 +1999,14 @@ bootstrapping. (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) @@ -1944,9 +2014,7 @@ bootstrapping. (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) @@ -2033,6 +2101,12 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) +(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 @@ -2050,9 +2124,7 @@ bootstrapping. (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 diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 6c43380..759e710 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -30,7 +30,7 @@ (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) - (values nil (method-fast-function method))) + (values nil (safe-method-fast-function method))) (let* ((pv-table (and fmf (method-function-pv-table fmf)))) (if (and fmf (or (null pv-table) wrappers)) (let* ((pv-wrappers (when pv-table @@ -81,7 +81,7 @@ (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) - (values nil (method-fast-function method))) + (values nil (safe-method-fast-function method))) (declare (ignore mf)) (let* ((pv-table (and fmf (method-function-pv-table fmf)))) (if (and fmf (or (null pv-table) wrappers-p)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 47debc0..92e1018 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -492,7 +492,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -581,14 +581,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -1369,14 +1369,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 1268040..879f26e 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -724,8 +724,8 @@ (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types gf (mapcar #'class-eq-type classes)))) - (method-function-get (or (method-fast-function (car methods)) - (method-function (car methods))) + (method-function-get (or (safe-method-fast-function (car methods)) + (safe-method-function (car methods))) :constant-value))) (defun default-secondary-dispatch-function (generic-function) diff --git a/tests/mop-12.impure-cload.lisp b/tests/mop-12.impure-cload.lisp new file mode 100644 index 0000000..5bcbbb0 --- /dev/null +++ b/tests/mop-12.impure-cload.lisp @@ -0,0 +1,80 @@ +;;;; 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)) diff --git a/tests/mop-13.impure-cload.lisp b/tests/mop-13.impure-cload.lisp new file mode 100644 index 0000000..1fbc789 --- /dev/null +++ b/tests/mop-13.impure-cload.lisp @@ -0,0 +1,81 @@ +;;;; 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)) diff --git a/version.lisp-expr b/version.lisp-expr index 4e036a8..63e84ab 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.9.24" +"0.9.9.25"