X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop-2.impure-cload.lisp;h=cc1042e1ea6773b87efa8177e63ec749ebe1d3e2;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=0f229a04e9af4ed98100a0f7a7101c400d686bb9;hpb=b171183c7115b865b00662ff346061ecd5291ce4;p=sbcl.git

diff --git a/tests/mop-2.impure-cload.lisp b/tests/mop-2.impure-cload.lisp
index 0f229a0..cc1042e 100644
--- a/tests/mop-2.impure-cload.lisp
+++ b/tests/mop-2.impure-cload.lisp
@@ -6,7 +6,7 @@
 ;;;; 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.
@@ -55,6 +55,9 @@
              (setf (cdr entry) new-value))
          new-value))
 
+  (defun dynamic-slot-names (instance)
+    (mapcar #'car (gethash instance table)))
+
    (defun dynamic-slot-boundp (instance slot-name)
       (let* ((alist (gethash instance table))
              (entry (assoc slot-name alist)))
@@ -66,7 +69,6 @@
         (unless (null entry)
           (setf (gethash instance table) (delete entry alist))))
       instance)
-
 )
 
 (defmethod allocate-instance ((class dynamic-slot-class) &key)
@@ -82,21 +84,21 @@
         (call-next-method))))
 
 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
-					  instance slotd)
+                                          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))))
+        (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)
+                                    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)
+                                        instance slotd)
   (let ((slot (find slotd (class-slots class))))
     (if (and slot (dynamic-slot-p slot))
         (dynamic-slot-makunbound instance (slot-definition-name slotd))
@@ -135,18 +137,18 @@
 
 (defmethod (setf slot-value-using-class) (new-value
                                           (class dynamic-slot-subclass)
-					  instance slotd)
+                                          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))))
+        (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))))
+        (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)
@@ -157,3 +159,79 @@
 (assert (not (slot-boundp *three* 'slot1)))
 (assert (eq (slot-value *three* 'slot2) t))
 (assert (= (slot-value *three* 'slot3) 3))
+
+(defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v)
+  (declare (ignore v))
+  (list :slot-missing slot-name))
+
+;;; Test redefinition adding a dynamic slot
+(defclass test-class-3 (test-class-1)
+  ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
+   (slot3 :initarg :slot3)
+   (slot4 :initarg :slot4 :initform 42 :allocation :dynamic))
+  (:metaclass dynamic-slot-subclass))
+(assert (= 42 (slot-value *three* 'slot4)))
+
+;;; Test redefinition removing a dynamic slot
+(defclass test-class-3 (test-class-1)
+  ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
+   (slot3 :initarg :slot3))
+  (:metaclass dynamic-slot-subclass))
+(assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4)))
+
+;;; Test redefinition making a dynamic slot local
+;;;
+;;; NOTE: seriously underspecified. We muddle somehow.
+(defclass test-class-3 (test-class-1)
+  ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
+   (slot3 :initarg :slot3))
+  (:metaclass dynamic-slot-subclass))
+(let* ((slots (class-slots (find-class 'test-class-3)))
+       (slot (find 'slot2 slots :key #'slot-definition-name)))
+  (assert (eq :instance (slot-definition-allocation slot)))
+  (assert (eq 'ok (slot-value *three* 'slot2))))
+
+;;; Test redefinition making a local slot dynamic again
+;;;
+;;; NOTE: seriously underspecified. We muddle somehow.
+;;; This picks up the old value from the table, not the
+;;; new initform.
+(defclass test-class-3 (test-class-1)
+  ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
+   (slot3 :initarg :slot3))
+  (:metaclass dynamic-slot-subclass))
+(let* ((slots (class-slots (find-class 'test-class-3)))
+       (slot (find 'slot2 slots :key #'slot-definition-name)))
+  (assert (eq :dynamic (slot-definition-allocation slot)))
+  (assert (eq t (slot-value *three* 'slot2))))
+
+;;; Test redefinition making a dynamic slot local, with
+;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
+;;; Then we make it dynamic again.
+;;;
+;;; NOTE: seriously underspecified. We muddle somehow.
+(defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
+                                                       &rest inits)
+  (declare (ignore inits))
+  (let* ((class (class-of obj))
+         (slots (class-slots class)))
+    (dolist (name (dynamic-slot-names obj))
+      (let ((slotd (find name slots :key #'slot-definition-name)))
+        (unless (and slotd (eq :dynamic (slot-definition-allocation slotd)))
+          (dynamic-slot-makunbound obj name))))))
+(defclass test-class-3 (test-class-1)
+  ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
+   (slot3 :initarg :slot3))
+  (:metaclass dynamic-slot-subclass))
+(let* ((slots (class-slots (find-class 'test-class-3)))
+       (slot (find 'slot2 slots :key #'slot-definition-name)))
+  (assert (eq :instance (slot-definition-allocation slot)))
+  (assert (eq 'ok (slot-value *three* 'slot2))))
+(defclass test-class-3 (test-class-1)
+  ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
+   (slot3 :initarg :slot3))
+  (:metaclass dynamic-slot-subclass))
+(let* ((slots (class-slots (find-class 'test-class-3)))
+       (slot (find 'slot2 slots :key #'slot-definition-name)))
+  (assert (eq :dynamic (slot-definition-allocation slot)))
+  (assert (eq 'ok! (slot-value *three* 'slot2))))