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 (defpackage "TEST" (:use "CL" "SB-MOP"))
  23 (in-package "TEST")
  24
  25 (defclass dynamic-slot-class (standard-class) ())
  26
  27 (defmethod validate-superclass
  28     ((class dynamic-slot-class) (super standard-class))
  29   t)
  30
  31 (defmethod compute-effective-slot-definition
  32            ((class dynamic-slot-class) name direct-slots)
  33   (let ((slot (call-next-method)))
  34     (setf (slot-definition-allocation slot) :dynamic)
  35     slot))
  36
  37 (defun dynamic-slot-p (slot)
  38   (eq (slot-definition-allocation slot) :dynamic))
  39
  40 (let ((table (make-hash-table)))
  41
  42    (defun allocate-table-entry (instance)
  43      (setf (gethash instance table) ()))
  44
  45    (defun read-dynamic-slot-value (instance slot-name)
  46      (let* ((alist (gethash instance table))
  47             (entry (assoc slot-name alist)))
  48         (if (null entry)
  49             (error "slot ~S unbound in ~S" slot-name instance)
  50             (cdr entry))))
  51
  52    (defun write-dynamic-slot-value (new-value instance slot-name)
  53       (let* ((alist (gethash instance table))
  54              (entry (assoc slot-name alist)))
  55          (if (null entry)
  56              (push `(,slot-name . ,new-value)
  57                    (gethash instance table))
  58              (setf (cdr entry) new-value))
  59          new-value))
  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
  75 (defmethod allocate-instance ((class dynamic-slot-class) &key)
  76   (let ((instance (call-next-method)))
  77     (allocate-table-entry instance)
  78     instance))
  79
  80 (defmethod slot-value-using-class ((class dynamic-slot-class)
  81                                    instance slotd)
  82   (let ((slot (find slotd (class-slots class))))
  83     (if slot
  84         (read-dynamic-slot-value instance (slot-definition-name slotd))
  85         (call-next-method))))
  86
  87 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
  88                                           instance slotd)
  89   (let ((slot (find slotd (class-slots class))))
  90     (if slot
  91         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
  92         (call-next-method))))
  93
  94 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
  95                                     instance slotd)
  96   (let ((slot (find slotd (class-slots class))))
  97     (if slot
  98         (dynamic-slot-boundp instance (slot-definition-name slotd))
  99         (call-next-method))))
 100
 101 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
 102                                         instance slotd)
 103   (let ((slot (find slotd (class-slots class))))
 104     (if slot
 105         (dynamic-slot-makunbound instance (slot-definition-name slotd))
 106         (call-next-method))))
 107
 108 (defclass test-class-1 ()
 109   ((slot1 :initarg :slot1)
 110    (slot2 :initarg :slot2 :initform nil))
 111   (:metaclass dynamic-slot-class))
 112
 113 (defclass test-class-2 (test-class-1)
 114   ((slot2 :initarg :slot2 :initform t)
 115    (slot3 :initarg :slot3))
 116   (:metaclass dynamic-slot-class))
 117
 118 (defvar *one* (make-instance 'test-class-1))
 119 (defvar *two* (make-instance 'test-class-2 :slot3 1))
 120
 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)))
 125