Clean up listify-rest-args VOP on x86-64.
[sbcl.git] / tests / mop-20.impure-cload.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 ;;; this file tests that user-defined methods can be used in
15 ;;; combination (ahem) with hairy bits of method-combination.
16
17 (defpackage "MOP-20"
18   (:use "CL" "SB-MOP"))
19
20 (in-package "MOP-20")
21
22 ;;; Simple test case from Pascal Costanza
23 (defgeneric test (arg)
24   (:method (arg) (format t "~D" arg) arg))
25
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))))
40
41 (defun run-test ()
42   (define-around-test)
43   (test 42))
44
45 (assert (string= (with-output-to-string (*standard-output*)
46                    (assert (= (run-test) 42)))
47                  "42"))
48 \f
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))
52
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
80
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)))
91
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))))
103
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))))
127
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))))