tests/mop-30.impure.lisp

   1 ;;;; Standard-instance-access tests and update-protocol abuse
   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 (defclass foo ()
  15   ((bar :initarg :bar)
  16    (quux :initarg :quux)))
  17
  18 (defclass foomagic ()
  19   ())
  20
  21 (defun find-slot (name class)
  22   (let ((class (sb-pcl:ensure-class-finalized (find-class class))))
  23     (find name (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name)))
  24
  25 (sb-mop:add-dependent (find-class 'foo) (find-class 'foomagic))
  26
  27 (defglobal **bar-loc** (sb-mop:slot-definition-location (find-slot 'bar 'foo)))
  28 (defglobal **quux-loc** (sb-mop:slot-definition-location (find-slot 'quux 'foo)))
  29
  30 (defmethod sb-mop:update-dependent ((meta (eql (find-class 'foo)))
  31                                     (dep (eql (find-class 'foomagic)))
  32                                     &key)
  33   (setf **bar-loc** (sb-mop:slot-definition-location (find-slot 'bar 'foo))
  34         **quux-loc** (sb-mop:slot-definition-location (find-slot 'quux 'foo))))
  35
  36 (defun foo-bar/quux (foo)
  37   (declare (type foo foo))
  38   (values (sb-mop:standard-instance-access foo **bar-loc**)
  39           (sb-mop:standard-instance-access foo **quux-loc**)))
  40
  41 (defun swap-bar/quux (foo)
  42   (declare (type foo foo))
  43   (rotatef (sb-mop:standard-instance-access foo **bar-loc**)
  44            (sb-mop:standard-instance-access foo **quux-loc**)))
  45
  46 (with-test (:name (:mop-30 sb-mop:standard-instance-access))
  47   (let ((bar (cons t t))
  48         (quux (cons nil nil)))
  49     (multiple-value-bind (bar? quux?)
  50         (foo-bar/quux (make-instance 'foo :bar bar :quux quux))
  51       (assert (eq bar bar?))
  52       (assert (eq quux quux?)))))
  53
  54 (with-test (:name (:mop-30 (setf sb-mop::standard-instance-access)))
  55   (let* ((bar (cons t t))
  56          (quux (cons nil nil))
  57          (foo
  58           (make-instance 'foo :bar bar :quux quux)))
  59     (multiple-value-bind (bar? quux?) (foo-bar/quux foo)
  60       (assert (eq bar bar?))
  61       (assert (eq quux quux?)))
  62     (swap-bar/quux foo)
  63     (multiple-value-bind (bar? quux?) (foo-bar/quux foo)
  64       (assert (eq quux bar?))
  65       (assert (eq bar quux?)))))
  66
  67 ;;; Sneaky redefinition reorders slots!
  68 (defclass foo ()
  69   ((quux :initarg :quux)
  70    (bar :initarg :bar)))
  71
  72 (with-test (:name (:mop-30 sb-mop:standard-instance-access :updated))
  73   (let ((bar (cons t t))
  74         (quux (cons nil nil)))
  75     (multiple-value-bind (bar? quux?)
  76         (foo-bar/quux (make-instance 'foo :bar bar :quux quux))
  77       (assert (eq bar bar?))
  78       (assert (eq quux quux?)))))
  79
  80 (with-test (:name (:mop-30 sb-mop:standard-instance-access slot-unbound))
  81   (let ((bar (cons t t)))
  82     (multiple-value-bind (bar? quux?)
  83         (foo-bar/quux (make-instance 'foo :bar bar))
  84       (assert (eq bar bar?))
  85       (assert (eq sb-pcl:+slot-unbound+ quux?)))))