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-boundp (instance slot-name)
  59       (let* ((alist (gethash instance table))
  60              (entry (assoc slot-name alist)))
  61         (not (null entry))))
  62
  63    (defun dynamic-slot-makunbound (instance slot-name)
  64       (let* ((alist (gethash instance table))
  65              (entry (assoc slot-name alist)))
  66         (unless (null entry)
  67           (setf (gethash instance table) (delete entry alist))))
  68       instance)
  69
  70 )
  71
  72 (defmethod allocate-instance ((class dynamic-slot-class) &key)
  73   (let ((instance (call-next-method)))
  74     (allocate-table-entry instance)
  75     instance))
  76
  77 (defmethod slot-value-using-class ((class dynamic-slot-class)
  78                                    instance slotd)
  79   (let ((slot (find slotd (class-slots class))))
  80     (if (and slot (dynamic-slot-p slot))
  81         (read-dynamic-slot-value instance (slot-definition-name slotd))
  82         (call-next-method))))
  83
  84 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
  85                                           instance slotd)
  86   (let ((slot (find slotd (class-slots class))))
  87     (if (and slot (dynamic-slot-p slot))
  88         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
  89         (call-next-method))))
  90
  91 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
  92                                     instance slotd)
  93   (let ((slot (find slotd (class-slots class))))
  94     (if (and slot (dynamic-slot-p slot))
  95         (dynamic-slot-boundp instance (slot-definition-name slotd))
  96         (call-next-method))))
  97
  98 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
  99                                         instance slotd)
 100   (let ((slot (find slotd (class-slots class))))
 101     (if (and slot (dynamic-slot-p slot))
 102         (dynamic-slot-makunbound instance (slot-definition-name slotd))
 103         (call-next-method))))
 104
 105 (defclass test-class-1 ()
 106   ((slot1 :initarg :slot1 :allocation :dynamic)
 107    (slot2 :initarg :slot2 :initform nil))
 108   (:metaclass dynamic-slot-class))
 109
 110 (defclass test-class-2 (test-class-1)
 111   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
 112    (slot3 :initarg :slot3))
 113   (:metaclass dynamic-slot-class))
 114
 115 (defvar *one* (make-instance 'test-class-1))
 116 (defvar *two* (make-instance 'test-class-2 :slot3 1))
 117
 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 slot-value-using-class ((class dynamic-slot-subclass)
 130                                    instance slotd)
 131   (let ((slot (find slotd (class-slots class))))
 132     (if (and slot (dynamic-slot-p slot))
 133         (read-dynamic-slot-value instance (slot-definition-name slotd))
 134         (call-next-method))))
 135
 136 (defmethod (setf slot-value-using-class) (new-value
 137                                           (class dynamic-slot-subclass)
 138                                           instance slotd)
 139   (let ((slot (find slotd (class-slots class))))
 140     (if (and slot (dynamic-slot-p slot))
 141         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
 142         (call-next-method))))
 143
 144 (defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
 145                                     instance slotd)
 146   (let ((slot (find slotd (class-slots class))))
 147     (if (and slot (dynamic-slot-p slot))
 148         (dynamic-slot-boundp instance (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 (assert (not (slot-boundp *three* 'slot1)))
 158 (assert (eq (slot-value *three* 'slot2) t))
 159 (assert (= (slot-value *three* 'slot3) 3))