Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / mop-24.impure.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 ;;; Some slot-valuish things in combination with user-defined methods
15
16 (defpackage "MOP-24"
17   (:use "CL" "SB-MOP"))
18
19 (in-package "MOP-24")
20
21 (defclass user-method (standard-method) (myslot))
22
23 (defmacro def-user-method (name &rest rest)
24   (let* ((lambdalist-position (position-if #'listp rest))
25          (qualifiers (subseq rest 0 lambdalist-position))
26          (lambdalist (elt rest lambdalist-position))
27          (body (subseq rest (+ lambdalist-position 1)))
28          (required-part
29           (subseq lambdalist 0
30                   (or (position-if #'(lambda (x)
31                                        (member x lambda-list-keywords))
32                                    lambdalist)
33                       (length lambdalist))))
34          (specializers
35           (mapcar #'find-class
36                   (mapcar #'(lambda (x) (if (consp x) (second x) 't))
37                           required-part)))
38          (unspecialized-required-part
39           (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part))
40          (unspecialized-lambdalist
41           (append unspecialized-required-part
42                   (subseq required-part (length required-part)))))
43     `(progn
44       (add-method #',name
45        (make-instance 'user-method
46         :qualifiers ',qualifiers
47         :lambda-list ',unspecialized-lambdalist
48         :specializers ',specializers
49         :function
50
51         #'(lambda (arguments next-methods-list)
52             (flet ((next-method-p () next-methods-list)
53                    (call-next-method (&rest new-arguments)
54                      (unless new-arguments (setq new-arguments arguments))
55                      (if (null next-methods-list)
56                          (error "no next method for arguments ~:s" arguments)
57                          (funcall (method-function (first next-methods-list))
58                                   new-arguments (rest next-methods-list)))))
59               (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
60       ',name)))
61
62 (defclass super ()
63   ((a :initarg :a :initform 3)))
64 (defclass sub (super)
65   ((b :initarg :b :initform 4)))
66 (defclass subsub (sub)
67   ((b :initarg :b :initform 5)
68    (a :initarg :a :initform 6)))
69
70 ;;; reworking of MOP-20 tests, but with slot-valuish things.
71 (progn
72   (defgeneric test-um03 (x))
73   (defmethod test-um03 ((x subsub))
74     (list* 'subsub (slot-value x 'a) (slot-value x 'b)
75            (not (null (next-method-p))) (call-next-method)))
76   (def-user-method test-um03 ((x sub))
77     (list* 'sub (slot-value x 'a) (slot-value x 'b)
78            (not (null (next-method-p))) (call-next-method)))
79   (defmethod test-um03 ((x super))
80     (list 'super (slot-value x 'a) (not (null (next-method-p)))))
81   (assert (equal (test-um03 (make-instance 'super)) '(super 3 nil)))
82   (assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil)))
83   (assert (equal (test-um03 (make-instance 'subsub))
84                  '(subsub 6 5 t sub 6 5 t super 6 nil))))
85
86 (progn
87   (defgeneric test-um10 (x))
88   (defmethod test-um10 ((x subsub))
89     (list* 'subsub (slot-value x 'a) (slot-value x 'b)
90            (not (null (next-method-p))) (call-next-method)))
91   (defmethod test-um10 ((x sub))
92     (list* 'sub (slot-value x 'a) (slot-value x 'b)
93            (not (null (next-method-p))) (call-next-method)))
94   (defmethod test-um10 ((x super))
95     (list 'super (slot-value x 'a) (not (null (next-method-p)))))
96   (defmethod test-um10 :after ((x super)))
97   (def-user-method test-um10 :around ((x subsub))
98     (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
99            (not (null (next-method-p))) (call-next-method)))
100   (defmethod test-um10 :around ((x sub))
101     (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
102            (not (null (next-method-p))) (call-next-method)))
103   (defmethod test-um10 :around ((x super))
104     (list* 'around-super (slot-value x 'a)
105            (not (null (next-method-p))) (call-next-method)))
106   (assert (equal (test-um10 (make-instance 'super))
107                  '(around-super 3 t super 3 nil)))
108   (assert (equal (test-um10 (make-instance 'sub))
109                  '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
110   (assert (equal (test-um10 (make-instance 'subsub))
111                  '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
112                    subsub 6 5 t sub 6 5 t super 6 nil))))
113
114 (progn
115   (defgeneric test-um12 (x))
116   (defmethod test-um12 ((x subsub))
117     (list* 'subsub (slot-value x 'a) (slot-value x 'b)
118            (not (null (next-method-p))) (call-next-method)))
119   (defmethod test-um12 ((x sub))
120     (list* 'sub (slot-value x 'a) (slot-value x 'b)
121            (not (null (next-method-p))) (call-next-method)))
122   (defmethod test-um12 ((x super))
123     (list 'super (slot-value x 'a) (not (null (next-method-p)))))
124   (defmethod test-um12 :after ((x super)))
125   (defmethod test-um12 :around ((x subsub))
126     (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
127            (not (null (next-method-p))) (call-next-method)))
128   (defmethod test-um12 :around ((x sub))
129     (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
130            (not (null (next-method-p))) (call-next-method)))
131   (def-user-method test-um12 :around ((x super))
132     (list* 'around-super (slot-value x 'a)
133            (not (null (next-method-p))) (call-next-method)))
134   (assert (equal (test-um12 (make-instance 'super))
135                  '(around-super 3 t super 3 nil)))
136   (assert (equal (test-um12 (make-instance 'sub))
137                  '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
138   (assert (equal (test-um12 (make-instance 'subsub))
139                  '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
140                    subsub 6 5 t sub 6 5 t super 6 nil))))