Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / 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?)))))