Merge branch 'master' of git://repo.or.cz/sbcl
[sbcl/attila.git] / tests / mop-20.impure-cload.lisp
blob8f1a6af8130949c2453ab44cffa576d99a862da4
1 ;;;; miscellaneous side-effectful tests of the MOP
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.
14 ;;; this file tests that user-defined methods can be used in
15 ;;; combination (ahem) with hairy bits of method-combination.
17 (defpackage "MOP-20"
18 (:use "CL" "SB-MOP"))
20 (in-package "MOP-20")
22 ;;; Simple test case from Pascal Costanza
23 (defgeneric test (arg)
24 (:method (arg) (format t "~D" arg) arg))
26 (defun define-around-test ()
27 (multiple-value-bind
28 (method-lambda method-args)
29 (make-method-lambda
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)
35 :lambda-list '(arg)
36 :specializers (list (find-class 't))
37 :function (compile nil method-lambda)
38 method-args)))
39 (add-method #'test method))))
41 (defun run-test ()
42 (define-around-test)
43 (test 42))
45 (assert (string= (with-output-to-string (*standard-output*)
46 (assert (= (run-test) 42)))
47 "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)))
58 (required-part
59 (subseq lambdalist 0
60 (or (position-if #'(lambda (x)
61 (member x lambda-list-keywords))
62 lambdalist)
63 (length lambdalist))))
64 (specializers
65 (mapcar #'find-class
66 (mapcar #'(lambda (x) (if (consp x) (second x) 't))
67 required-part)))
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)))))
73 `(progn
74 (add-method #',name
75 (make-instance 'user-method
76 :qualifiers ',qualifiers
77 :lambda-list ',unspecialized-lambdalist
78 :specializers ',specializers
79 :function
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)))))
90 ',name)))
92 ;;; this one has always worked, as it does not involve MAKE-METHOD in
93 ;;; its effective method.
94 (progn
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
105 (progn
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
122 around-rational 17 t
123 around-real 17 t
124 integer 17 t
125 rational 17 t
126 real 17 nil))))
128 (progn
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
145 around-rational 17 t
146 around-real 17 t
147 integer 17 t
148 rational 17 t
149 real 17 nil))))