tests/mop-2.impure-cload.lisp

   1 ;;;; miscellaneous side-effectful tests of the MOP
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;;; Note that the MOP is not in an entirely supported state.
  15 ;;;; However, this seems a good a way as any of ensuring that we have
  16 ;;;; no regressions.
  17
  18 ;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
  19 ;;; fixups for running in the full MOP rather than closette -- SLOTDs
  20 ;;; instead of slot-names, and so on -- and :allocation :dynamic for
  21 ;;; dynamic slots.
  22
  23 (defclass dynamic-slot-class (standard-class) ())
  24
  25 (defmethod sb-mop:validate-superclass
  26     ((class dynamic-slot-class) (super standard-class))
  27   t)
  28
  29 (defun dynamic-slot-p (slot)
  30   (eq (sb-mop:slot-definition-allocation slot) :dynamic))
  31
  32 (eval-when (:compile-toplevel :load-toplevel :execute)
  33   (let ((table (make-hash-table)))
  34
  35     (defun allocate-table-entry (instance)
  36       (setf (gethash instance table) ()))
  37
  38     (defun read-dynamic-slot-value (instance slot-name)
  39       (let* ((alist (gethash instance table))
  40              (entry (assoc slot-name alist)))
  41         (if (null entry)
  42             (error "slot ~S unbound in ~S" slot-name instance)
  43             (cdr entry))))
  44
  45     (defun write-dynamic-slot-value (new-value instance slot-name)
  46       (let* ((alist (gethash instance table))
  47              (entry (assoc slot-name alist)))
  48         (if (null entry)
  49             (push `(,slot-name . ,new-value)
  50                   (gethash instance table))
  51             (setf (cdr entry) new-value))
  52         new-value))
  53
  54     (defun dynamic-slot-names (instance)
  55       (mapcar #'car (gethash instance table)))
  56
  57     (defun dynamic-slot-boundp (instance slot-name)
  58       (let* ((alist (gethash instance table))
  59              (entry (assoc slot-name alist)))
  60         (not (null entry))))
  61
  62     (defun dynamic-slot-makunbound (instance slot-name)
  63       (let* ((alist (gethash instance table))
  64              (entry (assoc slot-name alist)))
  65         (unless (null entry)
  66           (setf (gethash instance table) (delete entry alist))))
  67       instance)
  68
  69     ))
  70
  71 (defmethod allocate-instance ((class dynamic-slot-class) &key)
  72   (let ((instance (call-next-method)))
  73     (allocate-table-entry instance)
  74     instance))
  75
  76 (defmethod sb-mop:slot-value-using-class ((class dynamic-slot-class)
  77                                           instance slotd)
  78   (let ((slot (find slotd (sb-mop:class-slots class))))
  79     (if (and slot (dynamic-slot-p slot))
  80         (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
  81         (call-next-method))))
  82
  83 (defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
  84                                                  instance slotd)
  85   (let ((slot (find slotd (sb-mop:class-slots class))))
  86     (if (and slot (dynamic-slot-p slot))
  87         (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
  88         (call-next-method))))
  89
  90 (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
  91                                            instance slotd)
  92   (let ((slot (find slotd (sb-mop:class-slots class))))
  93     (if (and slot (dynamic-slot-p slot))
  94         (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
  95         (call-next-method))))
  96
  97 (defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
  98                                                instance slotd)
  99   (let ((slot (find slotd (sb-mop:class-slots class))))
 100     (if (and slot (dynamic-slot-p slot))
 101         (dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
 102         (call-next-method))))
 103
 104 (defclass test-class-1 ()
 105   ((slot1 :initarg :slot1 :allocation :dynamic)
 106    (slot2 :initarg :slot2 :initform nil))
 107   (:metaclass dynamic-slot-class))
 108
 109 (defclass test-class-2 (test-class-1)
 110   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 111    (slot3 :initarg :slot3))
 112   (:metaclass dynamic-slot-class))
 113
 114 (defvar *one* (make-instance 'test-class-1))
 115 (defvar *two* (make-instance 'test-class-2 :slot3 1))
 116
 117 (with-test (:name (:mop-2 1))
 118   (assert (not (slot-boundp *one* 'slot1)))
 119   (assert (null (slot-value *one* 'slot2)))
 120   (assert (eq t (slot-value *two* 'slot2)))
 121   (assert (= 1 (slot-value *two* 'slot3))))
 122
 123 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
 124 ;;; overconservatism in accessing a class's precedence list deep in
 125 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
 126 ;;; finalizing a class.
 127 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
 128
 129 (defmethod sb-mop:slot-value-using-class ((class dynamic-slot-subclass)
 130                                           instance slotd)
 131   (let ((slot (find slotd (sb-mop:class-slots class))))
 132     (if (and slot (dynamic-slot-p slot))
 133         (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
 134         (call-next-method))))
 135
 136 (defmethod (setf sb-mop:slot-value-using-class) (new-value
 137                                                  (class dynamic-slot-subclass)
 138                                                  instance slotd)
 139   (let ((slot (find slotd (sb-mop:class-slots class))))
 140     (if (and slot (dynamic-slot-p slot))
 141         (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
 142         (call-next-method))))
 143
 144 (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-subclass)
 145                                            instance slotd)
 146   (let ((slot (find slotd (sb-mop:class-slots class))))
 147     (if (and slot (dynamic-slot-p slot))
 148         (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
 149         (call-next-method))))
 150
 151 (defclass test-class-3 (test-class-1)
 152   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 153    (slot3 :initarg :slot3))
 154   (:metaclass dynamic-slot-subclass))
 155
 156 (defvar *three* (make-instance 'test-class-3 :slot3 3))
 157
 158 (with-test (:name (:mop-2 2))
 159   (assert (not (slot-boundp *three* 'slot1)))
 160   (assert (eq (slot-value *three* 'slot2) t))
 161   (assert (= (slot-value *three* 'slot3) 3)))
 162
 163 (defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v)
 164   (declare (ignore v))
 165   (list :slot-missing slot-name))
 166
 167 ;;; Test redefinition adding a dynamic slot
 168 (defclass test-class-3 (test-class-1)
 169   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 170    (slot3 :initarg :slot3)
 171    (slot4 :initarg :slot4 :initform 42 :allocation :dynamic))
 172   (:metaclass dynamic-slot-subclass))
 173
 174 (with-test (:name (:mop-2 3))
 175   (assert (= 42 (slot-value *three* 'slot4))))
 176
 177 (with-test (:name (:mop-2 :slot-exists-p-before-removal))
 178   (let ((i (make-instance 'test-class-3)))
 179     (dolist (s '(slot1 slot2 slot3 slot4)) (assert (slot-exists-p i s)))))
 180
 181 ;;; Test redefinition removing a dynamic slot
 182 (defclass test-class-3 (test-class-1)
 183   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 184    (slot3 :initarg :slot3))
 185   (:metaclass dynamic-slot-subclass))
 186
 187 (with-test (:name (:mop-2 4))
 188   (assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4))))
 189
 190 (with-test (:name (:mop-2 :slot-exists-p-after-removal))
 191   (let ((i (make-instance 'test-class-3)))
 192     (assert (not (slot-exists-p i 'slot4)))
 193     (dolist (s '(slot1 slot2 slot3)) (assert (slot-exists-p i s)))))
 194
 195 ;;; Test redefinition making a dynamic slot local
 196 ;;;
 197 ;;; NOTE: seriously underspecified. We muddle somehow.
 198 (defclass test-class-3 (test-class-1)
 199   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
 200    (slot3 :initarg :slot3))
 201   (:metaclass dynamic-slot-subclass))
 202
 203 (with-test (:name (:mop-2 5))
 204   (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
 205          (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
 206     (assert (eq :instance (sb-mop:slot-definition-allocation slot)))
 207     (assert (eq 'ok (slot-value *three* 'slot2)))))
 208
 209 ;;; Test redefinition making a local slot dynamic again
 210 ;;;
 211 ;;; NOTE: seriously underspecified. We muddle somehow.
 212 ;;; This picks up the old value from the table, not the
 213 ;;; new initform.
 214 (defclass test-class-3 (test-class-1)
 215   ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
 216    (slot3 :initarg :slot3))
 217   (:metaclass dynamic-slot-subclass))
 218
 219 (with-test (:name (:mop-2 6))
 220   (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
 221          (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
 222     (assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
 223     (assert (eq t (slot-value *three* 'slot2)))))
 224
 225 ;;; Test redefinition making a dynamic slot local, with
 226 ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
 227 ;;; Then we make it dynamic again.
 228 ;;;
 229 ;;; NOTE: seriously underspecified. We muddle somehow.
 230 (defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
 231                                                        &rest inits)
 232   (declare (ignore inits))
 233   (let* ((class (class-of obj))
 234          (slots (sb-mop:class-slots class)))
 235     (dolist (name (dynamic-slot-names obj))
 236       (let ((slotd (find name slots :key #'sb-mop:slot-definition-name)))
 237         (unless (and slotd (eq :dynamic (sb-mop:slot-definition-allocation slotd)))
 238           (dynamic-slot-makunbound obj name))))))
 239
 240 (defclass test-class-3 (test-class-1)
 241   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
 242    (slot3 :initarg :slot3))
 243   (:metaclass dynamic-slot-subclass))
 244
 245 (with-test (:name (:mop-2 7))
 246   (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
 247          (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
 248     (assert (eq :instance (sb-mop:slot-definition-allocation slot)))
 249     (assert (eq 'ok (slot-value *three* 'slot2)))))
 250
 251 (defclass test-class-3 (test-class-1)
 252   ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
 253    (slot3 :initarg :slot3))
 254   (:metaclass dynamic-slot-subclass))
 255
 256 (with-test (:name (:mop-2 8))
 257   (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
 258          (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
 259     (assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
 260     (assert (eq 'ok! (slot-value *three* 'slot2)))))
 261
 262 (defclass makunbound-test-class (standard-class) ())
 263
 264 (defmethod sb-mop:validate-superclass ((class makunbound-test-class) (superclass standard-class))
 265   t)
 266
 267 (defmethod sb-mop:slot-makunbound-using-class ((class makunbound-test-class) object slotd)
 268   (throw 'slot-makunbound-using-class t))
 269
 270 (defclass test-class ()
 271   ((slot :initarg :slot))
 272   (:metaclass makunbound-test-class))
 273
 274 (with-test (:name :slot-makunbound-using-class)
 275   (assert (catch 'slot-makunbound-using-class
 276             (slot-makunbound (make-instance 'test-class) 'slot)
 277             nil)))