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 (untrace)
  24
  25 (defpackage "TEST" (:use "CL" "SB-MOP"))
  26 (in-package "TEST")
  27
  28 (defclass dynamic-slot-class (standard-class) ())
  29
  30 (defmethod validate-superclass
  31     ((class dynamic-slot-class) (super standard-class))
  32   t)
  33
  34 (defun dynamic-slot-p (slot)
  35   (eq (slot-definition-allocation slot) :dynamic))
  36
  37 (let ((table (make-hash-table)))
  38
  39    (defun allocate-table-entry (instance)
  40      (setf (gethash instance table) ()))
  41
  42    (defun read-dynamic-slot-value (instance slot-name)
  43      (let* ((alist (gethash instance table))
  44             (entry (assoc slot-name alist)))
  45         (if (null entry)
  46             (error "slot ~S unbound in ~S" slot-name instance)
  47             (cdr entry))))
  48
  49    (defun write-dynamic-slot-value (new-value instance slot-name)
  50       (let* ((alist (gethash instance table))
  51              (entry (assoc slot-name alist)))
  52          (if (null entry)
  53              (push `(,slot-name . ,new-value)
  54                    (gethash instance table))
  55              (setf (cdr entry) new-value))
  56          new-value))
  57
  58   (defun dynamic-slot-names (instance)
  59     (mapcar #'car (gethash instance table)))
  60
  61    (defun dynamic-slot-boundp (instance slot-name)
  62       (let* ((alist (gethash instance table))
  63              (entry (assoc slot-name alist)))
  64         (not (null entry))))
  65
  66    (defun dynamic-slot-makunbound (instance slot-name)
  67       (let* ((alist (gethash instance table))
  68              (entry (assoc slot-name alist)))
  69         (unless (null entry)
  70           (setf (gethash instance table) (delete entry alist))))
  71       instance)
  72 )
  73
  74 (defmethod allocate-instance ((class dynamic-slot-class) &key)
  75   (let ((instance (call-next-method)))
  76     (allocate-table-entry instance)
  77     instance))
  78
  79 (defmethod slot-value-using-class ((class dynamic-slot-class)
  80                                    instance slotd)
  81   (let ((slot (find slotd (class-slots class))))
  82     (if (and slot (dynamic-slot-p slot))
  83         (read-dynamic-slot-value instance (slot-definition-name slotd))
  84         (call-next-method))))
  85
  86 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
  87                                           instance slotd)
  88   (let ((slot (find slotd (class-slots class))))
  89     (if (and slot (dynamic-slot-p slot))
  90         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
  91         (call-next-method))))
  92
  93 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
  94                                     instance slotd)
  95   (let ((slot (find slotd (class-slots class))))
  96     (if (and slot (dynamic-slot-p slot))
  97         (dynamic-slot-boundp instance (slot-definition-name slotd))
  98         (call-next-method))))
  99
 100 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
 101                                         instance slotd)
 102   (let ((slot (find slotd (class-slots class))))
 103     (if (and slot (dynamic-slot-p slot))
 104         (dynamic-slot-makunbound instance (slot-definition-name slotd))
 105         (call-next-method))))
 106
 107 (defclass test-class-1 ()
 108   ((slot1 :initarg :slot1 :allocation :dynamic)
 109    (slot2 :initarg :slot2 :initform nil))
 110   (:metaclass dynamic-slot-class))
 111
 112 (defclass test-class-2 (test-class-1)
 113   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 114    (slot3 :initarg :slot3))
 115   (:metaclass dynamic-slot-class))
 116
 117 (defvar *one* (make-instance 'test-class-1))
 118 (defvar *two* (make-instance 'test-class-2 :slot3 1))
 119
 120 (assert (not (slot-boundp *one* 'slot1)))
 121 (assert (null (slot-value *one* 'slot2)))
 122 (assert (eq t (slot-value *two* 'slot2)))
 123 (assert (= 1 (slot-value *two* 'slot3)))
 124
 125 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
 126 ;;; overconservatism in accessing a class's precedence list deep in
 127 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
 128 ;;; finalizing a class.
 129 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
 130
 131 (defmethod slot-value-using-class ((class dynamic-slot-subclass)
 132                                    instance slotd)
 133   (let ((slot (find slotd (class-slots class))))
 134     (if (and slot (dynamic-slot-p slot))
 135         (read-dynamic-slot-value instance (slot-definition-name slotd))
 136         (call-next-method))))
 137
 138 (defmethod (setf slot-value-using-class) (new-value
 139                                           (class dynamic-slot-subclass)
 140                                           instance slotd)
 141   (let ((slot (find slotd (class-slots class))))
 142     (if (and slot (dynamic-slot-p slot))
 143         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
 144         (call-next-method))))
 145
 146 (defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
 147                                     instance slotd)
 148   (let ((slot (find slotd (class-slots class))))
 149     (if (and slot (dynamic-slot-p slot))
 150         (dynamic-slot-boundp instance (slot-definition-name slotd))
 151         (call-next-method))))
 152
 153 (defclass test-class-3 (test-class-1)
 154   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 155    (slot3 :initarg :slot3))
 156   (:metaclass dynamic-slot-subclass))
 157
 158 (defvar *three* (make-instance 'test-class-3 :slot3 3))
 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 (assert (= 42 (slot-value *three* 'slot4)))
 174
 175 (test-util:with-test (:name :slot-exists-p-before-removal)
 176   (let ((i (make-instance 'test-class-3)))
 177     (dolist (s '(slot1 slot2 slot3 slot4)) (assert (slot-exists-p i s)))))
 178
 179 ;;; Test redefinition removing a dynamic slot
 180 (defclass test-class-3 (test-class-1)
 181   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 182    (slot3 :initarg :slot3))
 183   (:metaclass dynamic-slot-subclass))
 184 (assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4)))
 185
 186 (test-util:with-test (:name :slot-exists-p-after-removal)
 187   (let ((i (make-instance 'test-class-3)))
 188     (assert (not (slot-exists-p i 'slot4)))
 189     (dolist (s '(slot1 slot2 slot3)) (assert (slot-exists-p i s)))))
 190
 191 ;;; Test redefinition making a dynamic slot local
 192 ;;;
 193 ;;; NOTE: seriously underspecified. We muddle somehow.
 194 (defclass test-class-3 (test-class-1)
 195   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
 196    (slot3 :initarg :slot3))
 197   (:metaclass dynamic-slot-subclass))
 198 (let* ((slots (class-slots (find-class 'test-class-3)))
 199        (slot (find 'slot2 slots :key #'slot-definition-name)))
 200   (assert (eq :instance (slot-definition-allocation slot)))
 201   (assert (eq 'ok (slot-value *three* 'slot2))))
 202
 203 ;;; Test redefinition making a local slot dynamic again
 204 ;;;
 205 ;;; NOTE: seriously underspecified. We muddle somehow.
 206 ;;; This picks up the old value from the table, not the
 207 ;;; new initform.
 208 (defclass test-class-3 (test-class-1)
 209   ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
 210    (slot3 :initarg :slot3))
 211   (:metaclass dynamic-slot-subclass))
 212 (let* ((slots (class-slots (find-class 'test-class-3)))
 213        (slot (find 'slot2 slots :key #'slot-definition-name)))
 214   (assert (eq :dynamic (slot-definition-allocation slot)))
 215   (assert (eq t (slot-value *three* 'slot2))))
 216
 217 ;;; Test redefinition making a dynamic slot local, with
 218 ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
 219 ;;; Then we make it dynamic again.
 220 ;;;
 221 ;;; NOTE: seriously underspecified. We muddle somehow.
 222 (defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
 223                                                        &rest inits)
 224   (declare (ignore inits))
 225   (let* ((class (class-of obj))
 226          (slots (class-slots class)))
 227     (dolist (name (dynamic-slot-names obj))
 228       (let ((slotd (find name slots :key #'slot-definition-name)))
 229         (unless (and slotd (eq :dynamic (slot-definition-allocation slotd)))
 230           (dynamic-slot-makunbound obj name))))))
 231 (defclass test-class-3 (test-class-1)
 232   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
 233    (slot3 :initarg :slot3))
 234   (:metaclass dynamic-slot-subclass))
 235 (let* ((slots (class-slots (find-class 'test-class-3)))
 236        (slot (find 'slot2 slots :key #'slot-definition-name)))
 237   (assert (eq :instance (slot-definition-allocation slot)))
 238   (assert (eq 'ok (slot-value *three* 'slot2))))
 239 (defclass test-class-3 (test-class-1)
 240   ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
 241    (slot3 :initarg :slot3))
 242   (:metaclass dynamic-slot-subclass))
 243 (let* ((slots (class-slots (find-class 'test-class-3)))
 244        (slot (find 'slot2 slots :key #'slot-definition-name)))
 245   (assert (eq :dynamic (slot-definition-allocation slot)))
 246   (assert (eq 'ok! (slot-value *three* 'slot2))))