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