1 ;;;; miscellaneous side-effectful tests of the MOP
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 ;;; this file tests that user-defined methods can be used in
15 ;;; combination (ahem) with hairy bits of method-combination.
22 ;;; Simple test case from Pascal Costanza
23 (defgeneric test
(arg)
24 (:method
(arg) (format t
"~D" arg
) arg
))
26 (defun define-around-test ()
28 (method-lambda method-args
)
30 #'test
(class-prototype (generic-function-method-class #'test
))
31 '(lambda (arg) (call-next-method)) ())
32 (let ((method (apply #'make-instance
33 (generic-function-method-class #'test
)
34 :qualifiers
'(:around
)
36 :specializers
(list (find-class 't
))
37 :function
(compile nil method-lambda
)
39 (add-method #'test method
))))
45 (assert (string= (with-output-to-string (*standard-output
*)
46 (assert (= (run-test) 42)))
49 ;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel
50 ;;; 2004-06-11). First the setup.
51 (defclass user-method
(standard-method) (myslot))
53 (defmacro def-user-method
(name &rest rest
)
54 (let* ((lambdalist-position (position-if #'listp rest
))
55 (qualifiers (subseq rest
0 lambdalist-position
))
56 (lambdalist (elt rest lambdalist-position
))
57 (body (subseq rest
(+ lambdalist-position
1)))
60 (or (position-if #'(lambda (x)
61 (member x lambda-list-keywords
))
63 (length lambdalist
))))
66 (mapcar #'(lambda (x) (if (consp x
) (second x
) 't
))
68 (unspecialized-required-part
69 (mapcar #'(lambda (x) (if (consp x
) (first x
) x
)) required-part
))
70 (unspecialized-lambdalist
71 (append unspecialized-required-part
72 (subseq required-part
(length required-part
)))))
75 (make-instance 'user-method
76 :qualifiers
',qualifiers
77 :lambda-list
',unspecialized-lambdalist
78 :specializers
',specializers
81 #'(lambda (arguments next-methods-list
)
82 (flet ((next-method-p () next-methods-list
)
83 (call-next-method (&rest new-arguments
)
84 (unless new-arguments
(setq new-arguments arguments
))
85 (if (null next-methods-list
)
86 (error "no next method for arguments ~:s" arguments
)
87 (funcall (method-function (first next-methods-list
))
88 new-arguments
(rest next-methods-list
)))))
89 (apply #'(lambda ,unspecialized-lambdalist
,@body
) arguments
)))))
92 ;;; this one has always worked, as it does not involve MAKE-METHOD in
93 ;;; its effective method.
95 (defgeneric test-um03
(x))
96 (defmethod test-um03 ((x integer
))
97 (list* 'integer x
(not (null (next-method-p))) (call-next-method)))
98 (def-user-method test-um03
((x rational
))
99 (list* 'rational x
(not (null (next-method-p))) (call-next-method)))
100 (defmethod test-um03 ((x real
))
101 (list 'real x
(not (null (next-method-p)))))
102 (assert (equal (test-um03 17) '(integer 17 t rational
17 t real
17 nil
))))
104 ;;; these two used to fail in slightly different ways
106 (defgeneric test-um10
(x))
107 (defmethod test-um10 ((x integer
))
108 (list* 'integer x
(not (null (next-method-p))) (call-next-method)))
109 (defmethod test-um10 ((x rational
))
110 (list* 'rational x
(not (null (next-method-p))) (call-next-method)))
111 (defmethod test-um10 ((x real
))
112 (list 'real x
(not (null (next-method-p)))))
113 (defmethod test-um10 :after
((x real
)))
114 (def-user-method test-um10
:around
((x integer
))
115 (list* 'around-integer x
(not (null (next-method-p))) (call-next-method)))
116 (defmethod test-um10 :around
((x rational
))
117 (list* 'around-rational x
(not (null (next-method-p))) (call-next-method)))
118 (defmethod test-um10 :around
((x real
))
119 (list* 'around-real x
(not (null (next-method-p))) (call-next-method)))
120 (assert (equal (test-um10 17)
121 '(around-integer 17 t
129 (defgeneric test-um12
(x))
130 (defmethod test-um12 ((x integer
))
131 (list* 'integer x
(not (null (next-method-p))) (call-next-method)))
132 (defmethod test-um12 ((x rational
))
133 (list* 'rational x
(not (null (next-method-p))) (call-next-method)))
134 (defmethod test-um12 ((x real
))
135 (list 'real x
(not (null (next-method-p)))))
136 (defmethod test-um12 :after
((x real
)))
137 (defmethod test-um12 :around
((x integer
))
138 (list* 'around-integer x
(not (null (next-method-p))) (call-next-method)))
139 (defmethod test-um12 :around
((x rational
))
140 (list* 'around-rational x
(not (null (next-method-p))) (call-next-method)))
141 (def-user-method test-um12
:around
((x real
))
142 (list* 'around-real x
(not (null (next-method-p))) (call-next-method)))
143 (assert (equal (test-um12 17)
144 '(around-integer 17 t