From b171183c7115b865b00662ff346061ecd5291ce4 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 19 Sep 2004 09:32:21 +0000 Subject: [PATCH] 0.8.14.27: Fix for "Strange bug in MOP" (R. Mattes sbcl-help 2004-09-15) ... we need the CPL before the class has been fully finalized; ... can't use SLOT-BOUNDP (see note in CPL-OR-NIL); ... define new slot in class to hold boundp information. --- NEWS | 7 +- src/pcl/braid.lisp | 1 + src/pcl/defs.lisp | 4 ++ src/pcl/dfun.lisp | 21 ++++-- src/pcl/std-class.lisp | 26 ++++--- tests/mop-2.impure-cload.lisp | 159 +++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 203 insertions(+), 17 deletions(-) create mode 100644 tests/mop-2.impure-cload.lisp diff --git a/NEWS b/NEWS index a18eb08..b3d7f5f 100644 --- a/NEWS +++ b/NEWS @@ -10,12 +10,12 @@ changes in sbcl-0.8.15 relative to sbcl-0.8.14: Timothy Moore's work for CMUCL) * bug fix: DEFTYPE lambda-list parsing now binds unsupplied keyword parameters to * instead of NIL if no initform is supplied. - (reported by Johan Bockgård) + (reported by Johan Bockgaard) * bug fix: DEFINE-COMPILER-MACRO lambda-list parsing now binds correctly when FUNCALL appears as the car of the form. Note: despite this FUNCALL forms are not currently subject to compiler-macro expansion. (port of Raymond Toy's fix for the - same from CMUCL, reported by Johan Bockgård) + same from CMUCL, reported by Johan Bockgaard) * bug fix: FOR ... ON ... -clauses in LOOP now work on dotted lists (thanks for Teemu Kalvas) * bug fix: in FORMAT ~^ inside ~:{ now correctly steps to the next @@ -23,6 +23,9 @@ changes in sbcl-0.8.15 relative to sbcl-0.8.14: Squires, Sean Champ and Raymond Toy) * bug fix: incorrect expansion of defgeneric that caused a style warning. (thanks for Zach Beane) + * bug fix: slot accessor effective method computation works properly + for classes with multiple non-standard applicable methods on + SB-MOP:SLOT-VALUE-USING-CLASS. (reported by Ralf Mattes) * on x86 compiler supports stack allocation of results of LIST and LIST*, bound to variables, declared DYNAMIC-EXTENT. (based on CMUCL implementation by Gerd Moellmann) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 6d3eb82..3b87419 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -285,6 +285,7 @@ class) spec)) (set-slot 'class-precedence-list (classes cpl)) + (set-slot 'cpl-available-p t) (set-slot 'can-precede-list (classes (cdr cpl))) (set-slot 'incompatible-superclass-list nil) (set-slot 'direct-superclasses (classes direct-supers)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index f247747..2de8e27 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -420,6 +420,10 @@ (defclass pcl-class (class) ((class-precedence-list :reader class-precedence-list) + ;; KLUDGE: see note in CPL-OR-NIL + (cpl-available-p + :reader cpl-available-p + :initform nil) (can-precede-list :initform () :reader class-can-precede-list) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index bcce170..2b84a18 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -209,11 +209,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (funcallable-standard-instance-access object location) (standard-instance-access object location)))) (when (eq +slot-unbound+ value) - (error "~@" + (error "~@" slot-name class object)) value) - (error "~@" + (error "~@" slot-name class object)))) (defun standard-slot-value/gf (gf slot-name) @@ -1501,7 +1501,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) - (when (class-finalized-p class) + ;; KLUDGE: why not use (slot-boundp class + ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is + ;; used within COMPUTE-APPLICABLE-METHODS, including for + ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for + ;; breaking such nasty cycles in effective method computation + ;; only works for readers and writers, not boundps. It might + ;; not be too hard to make it work for BOUNDP accessors, but in + ;; the meantime we use an extra slot for exactly the result of + ;; the SLOT-BOUNDP that we want. (We cannot use + ;; CLASS-FINALIZED-P, because in the process of class + ;; finalization we need to use the CPL which has been computed + ;; to cache effective methods for slot accessors.) -- CSR, + ;; 2004-09-19. + (when (cpl-available-p class) (class-precedence-list class)) (early-class-precedence-list class))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index fdc3ebb..5cbb272 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -587,7 +587,8 @@ &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) - (with-slots (wrapper class-precedence-list prototype predicate-name + (with-slots (wrapper class-precedence-list cpl-available-p + prototype predicate-name (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) @@ -598,6 +599,7 @@ (setq direct-supers direct-superclasses) (setq wrapper (classoid-layout classoid)) (setq class-precedence-list (compute-class-precedence-list class)) + (setq cpl-available-p t) (add-direct-subclasses class direct-superclasses) (setq predicate-name (make-class-predicate-name (class-name class))) (make-class-predicate class predicate-name) @@ -727,12 +729,12 @@ instance)))) (defmethod shared-initialize :after - ((class structure-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - direct-default-initargs - (predicate-name nil predicate-name-p)) + ((class structure-class) + slot-names + &key (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + direct-default-initargs + (predicate-name nil predicate-name-p)) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) @@ -779,7 +781,8 @@ (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'class-precedence-list) - (compute-class-precedence-list class)) + (compute-class-precedence-list class)) + (setf (slot-value class 'cpl-available-p) t) (setf (slot-value class 'slots) (compute-slots class)) (let ((lclass (find-classoid (class-name class)))) (setf (classoid-pcl-class lclass) class) @@ -882,7 +885,7 @@ (update-cpl class (compute-class-precedence-list class)) ;; This invocation of UPDATE-SLOTS, in practice, finalizes the ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE - ;; is called at finalization, so that MOP programmers can hook + ;; is called at finalization, so that MOP programmers can hook ;; into the system as described in "Class Finalization Protocol" ;; (section 5.5.2 of AMOP). (update-slots class (compute-slots class)) @@ -903,8 +906,11 @@ ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class 'cpl-available-p) t) (force-cache-flushes class)) - (setf (slot-value class 'class-precedence-list) cpl)) + (progn + (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class 'cpl-available-p) t))) (update-class-can-precede-p cpl)) (defun update-class-can-precede-p (cpl) diff --git a/tests/mop-2.impure-cload.lisp b/tests/mop-2.impure-cload.lisp new file mode 100644 index 0000000..0f229a0 --- /dev/null +++ b/tests/mop-2.impure-cload.lisp @@ -0,0 +1,159 @@ +;;;; 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. + +;;;; Note that the MOP is not in an entirely supported state. +;;;; However, this seems a good a way as any of ensuring that we have +;;;; no regressions. + +;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with +;;; fixups for running in the full MOP rather than closette -- SLOTDs +;;; instead of slot-names, and so on -- and :allocation :dynamic for +;;; dynamic slots. + +(untrace) + +(defpackage "TEST" (:use "CL" "SB-MOP")) +(in-package "TEST") + +(defclass dynamic-slot-class (standard-class) ()) + +(defmethod validate-superclass + ((class dynamic-slot-class) (super standard-class)) + t) + +(defun dynamic-slot-p (slot) + (eq (slot-definition-allocation slot) :dynamic)) + +(let ((table (make-hash-table))) + + (defun allocate-table-entry (instance) + (setf (gethash instance table) ())) + + (defun read-dynamic-slot-value (instance slot-name) + (let* ((alist (gethash instance table)) + (entry (assoc slot-name alist))) + (if (null entry) + (error "slot ~S unbound in ~S" slot-name instance) + (cdr entry)))) + + (defun write-dynamic-slot-value (new-value instance slot-name) + (let* ((alist (gethash instance table)) + (entry (assoc slot-name alist))) + (if (null entry) + (push `(,slot-name . ,new-value) + (gethash instance table)) + (setf (cdr entry) new-value)) + new-value)) + + (defun dynamic-slot-boundp (instance slot-name) + (let* ((alist (gethash instance table)) + (entry (assoc slot-name alist))) + (not (null entry)))) + + (defun dynamic-slot-makunbound (instance slot-name) + (let* ((alist (gethash instance table)) + (entry (assoc slot-name alist))) + (unless (null entry) + (setf (gethash instance table) (delete entry alist)))) + instance) + +) + +(defmethod allocate-instance ((class dynamic-slot-class) &key) + (let ((instance (call-next-method))) + (allocate-table-entry instance) + instance)) + +(defmethod slot-value-using-class ((class dynamic-slot-class) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (read-dynamic-slot-value instance (slot-definition-name slotd)) + (call-next-method)))) + +(defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) + (call-next-method)))) + +(defmethod slot-boundp-using-class ((class dynamic-slot-class) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (dynamic-slot-boundp instance (slot-definition-name slotd)) + (call-next-method)))) + +(defmethod slot-makunbound-using-class ((class dynamic-slot-class) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (dynamic-slot-makunbound instance (slot-definition-name slotd)) + (call-next-method)))) + +(defclass test-class-1 () + ((slot1 :initarg :slot1 :allocation :dynamic) + (slot2 :initarg :slot2 :initform nil)) + (:metaclass dynamic-slot-class)) + +(defclass test-class-2 (test-class-1) + ((slot2 :initarg :slot2 :initform t :allocation :dynamic) + (slot3 :initarg :slot3)) + (:metaclass dynamic-slot-class)) + +(defvar *one* (make-instance 'test-class-1)) +(defvar *two* (make-instance 'test-class-2 :slot3 1)) + +(assert (not (slot-boundp *one* 'slot1))) +(assert (null (slot-value *one* 'slot2))) +(assert (eq t (slot-value *two* 'slot2))) +(assert (= 1 (slot-value *two* 'slot3))) + +;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by +;;; overconservatism in accessing a class's precedence list deep in +;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of +;;; finalizing a class. +(defclass dynamic-slot-subclass (dynamic-slot-class) ()) + +(defmethod slot-value-using-class ((class dynamic-slot-subclass) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (read-dynamic-slot-value instance (slot-definition-name slotd)) + (call-next-method)))) + +(defmethod (setf slot-value-using-class) (new-value + (class dynamic-slot-subclass) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) + (call-next-method)))) + +(defmethod slot-boundp-using-class ((class dynamic-slot-subclass) + instance slotd) + (let ((slot (find slotd (class-slots class)))) + (if (and slot (dynamic-slot-p slot)) + (dynamic-slot-boundp instance (slot-definition-name slotd)) + (call-next-method)))) + +(defclass test-class-3 (test-class-1) + ((slot2 :initarg :slot2 :initform t :allocation :dynamic) + (slot3 :initarg :slot3)) + (:metaclass dynamic-slot-subclass)) + +(defvar *three* (make-instance 'test-class-3 :slot3 3)) +(assert (not (slot-boundp *three* 'slot1))) +(assert (eq (slot-value *three* 'slot2) t)) +(assert (= (slot-value *three* 'slot3) 3)) diff --git a/version.lisp-expr b/version.lisp-expr index 0168b3e..6c958f1 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.8.14.26" +"0.8.14.27" -- 1.7.10.4