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
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)
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))
(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)
(funcallable-standard-instance-access object location)
(standard-instance-access object location))))
(when (eq +slot-unbound+ value)
- (error "~@<slot ~s of class ~s is unbound in object ~s~@:>"
+ (error "~@<slot ~S of class ~S is unbound in object ~S~@:>"
slot-name class object))
value)
- (error "~@<cannot get standard value of slot ~s of class ~s ~
- in object ~s~@:>"
+ (error "~@<cannot get standard value of slot ~S of class ~S ~
+ in object ~S~@:>"
slot-name class object))))
(defun standard-slot-value/gf (gf slot-name)
(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)))
&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)
(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)
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)
(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)
(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))
;; 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)
--- /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.
+
+;;;; 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))
;;; 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"
projects / sbcl.git / commitdiff