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 redefinition removing a dynamic slot
 176 (defclass test-class-3 (test-class-1)
 177   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 178    (slot3 :initarg :slot3))
 179   (:metaclass dynamic-slot-subclass))
 180 (assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4)))
 181
 182 ;;; Test redefinition making a dynamic slot local
 183 ;;;
 184 ;;; NOTE: seriously underspecified. We muddle somehow.
 185 (defclass test-class-3 (test-class-1)
 186   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
 187    (slot3 :initarg :slot3))
 188   (:metaclass dynamic-slot-subclass))
 189 (let* ((slots (class-slots (find-class 'test-class-3)))
 190        (slot (find 'slot2 slots :key #'slot-definition-name)))
 191   (assert (eq :instance (slot-definition-allocation slot)))
 192   (assert (eq 'ok (slot-value *three* 'slot2))))
 193
 194 ;;; Test redefinition making a local slot dynamic again
 195 ;;;
 196 ;;; NOTE: seriously underspecified. We muddle somehow.
 197 ;;; This picks up the old value from the table, not the
 198 ;;; new initform.
 199 (defclass test-class-3 (test-class-1)
 200   ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
 201    (slot3 :initarg :slot3))
 202   (:metaclass dynamic-slot-subclass))
 203 (let* ((slots (class-slots (find-class 'test-class-3)))
 204        (slot (find 'slot2 slots :key #'slot-definition-name)))
 205   (assert (eq :dynamic (slot-definition-allocation slot)))
 206   (assert (eq t (slot-value *three* 'slot2))))
 207
 208 ;;; Test redefinition making a dynamic slot local, with
 209 ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
 210 ;;; Then we make it dynamic again.
 211 ;;;
 212 ;;; NOTE: seriously underspecified. We muddle somehow.
 213 (defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
 214                                                        &rest inits)
 215   (declare (ignore inits))
 216   (let* ((class (class-of obj))
 217          (slots (class-slots class)))
 218     (dolist (name (dynamic-slot-names obj))
 219       (let ((slotd (find name slots :key #'slot-definition-name)))
 220         (unless (and slotd (eq :dynamic (slot-definition-allocation slotd)))
 221           (dynamic-slot-makunbound obj name))))))
 222 (defclass test-class-3 (test-class-1)
 223   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
 224    (slot3 :initarg :slot3))
 225   (:metaclass dynamic-slot-subclass))
 226 (let* ((slots (class-slots (find-class 'test-class-3)))
 227        (slot (find 'slot2 slots :key #'slot-definition-name)))
 228   (assert (eq :instance (slot-definition-allocation slot)))
 229   (assert (eq 'ok (slot-value *three* 'slot2))))
 230 (defclass test-class-3 (test-class-1)
 231   ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
 232    (slot3 :initarg :slot3))
 233   (:metaclass dynamic-slot-subclass))
 234 (let* ((slots (class-slots (find-class 'test-class-3)))
 235        (slot (find 'slot2 slots :key #'slot-definition-name)))
 236   (assert (eq :dynamic (slot-definition-allocation slot)))
 237   (assert (eq 'ok! (slot-value *three* 'slot2))))