tests/mop-1.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.
  21
  22 (defclass dynamic-slot-class (standard-class) ())
  23
  24 (defmethod sb-mop:validate-superclass
  25     ((class dynamic-slot-class) (super standard-class))
  26   t)
  27
  28 (defmethod sb-mop:compute-effective-slot-definition
  29            ((class dynamic-slot-class) name direct-slots)
  30   (let ((slot (call-next-method)))
  31     (setf (sb-mop:slot-definition-allocation slot) :dynamic)
  32     slot))
  33
  34 (defun dynamic-slot-p (slot)
  35   (eq (sb-mop:slot-definition-allocation slot) :dynamic))
  36
  37 (eval-when (:compile-toplevel :load-toplevel :execute)
  38
  39   (let ((table (make-hash-table)))
  40
  41     (defun allocate-table-entry (instance)
  42       (setf (gethash instance table) ()))
  43
  44     (defun read-dynamic-slot-value (instance slot-name)
  45       (let* ((alist (gethash instance table))
  46              (entry (assoc slot-name alist)))
  47         (if (null entry)
  48             (error "slot ~S unbound in ~S" slot-name instance)
  49             (cdr entry))))
  50
  51     (defun write-dynamic-slot-value (new-value instance slot-name)
  52       (let* ((alist (gethash instance table))
  53              (entry (assoc slot-name alist)))
  54         (if (null entry)
  55             (push `(,slot-name . ,new-value)
  56                   (gethash instance table))
  57             (setf (cdr entry) new-value))
  58         new-value))
  59
  60     (defun dynamic-slot-boundp (instance slot-name)
  61       (let* ((alist (gethash instance table))
  62              (entry (assoc slot-name alist)))
  63         (not (null entry))))
  64
  65     (defun dynamic-slot-makunbound (instance slot-name)
  66       (let* ((alist (gethash instance table))
  67              (entry (assoc slot-name alist)))
  68         (unless (null entry)
  69           (setf (gethash instance table) (delete entry alist))))
  70       instance)
  71
  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 sb-mop:slot-value-using-class ((class dynamic-slot-class)
  80                                           instance slotd)
  81   (let ((slot (find slotd (sb-mop:class-slots class))))
  82     (if slot
  83         (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
  84         (call-next-method))))
  85
  86 (defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
  87                                                  instance slotd)
  88   (let ((slot (find slotd (sb-mop:class-slots class))))
  89     (if slot
  90         (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
  91         (call-next-method))))
  92
  93 (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
  94                                            instance slotd)
  95   (let ((slot (find slotd (sb-mop:class-slots class))))
  96     (if slot
  97         (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
  98         (call-next-method))))
  99
 100 (defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
 101                                                instance slotd)
 102   (let ((slot (find slotd (sb-mop:class-slots class))))
 103     (if slot
 104         (dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
 105         (call-next-method))))
 106
 107 (defclass test-class-1 ()
 108   ((slot1 :initarg :slot1)
 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)
 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 (with-test (:name :mop-1)
 121   (assert (not (slot-boundp *one* 'slot1)))
 122   (assert (null (slot-value *one* 'slot2)))
 123   (assert (eq t (slot-value *two* 'slot2)))
 124   (assert (= 1 (slot-value *two* 'slot3))))