Really restore clisp cross-compilation.
[sbcl.git] / tests / mop-3.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 contains two tests for COMPUTE-APPLICABLE-METHODS on
15 ;;; subclasses of generic functions.
16
17 ;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
18
19 (defpackage "MOP-3"
20   (:use "CL" "SB-MOP"))
21
22 (in-package "MOP-3")
23
24 (defclass msl-generic-function (standard-generic-function)
25   ()
26   (:metaclass funcallable-standard-class))
27
28 (defun reverse-method-list (methods)
29   (let ((result '()))
30     (dolist (method methods)
31       (if (and (consp result)
32                (equal (method-qualifiers method)
33                       (method-qualifiers (caar result))))
34           (push method (car result))
35           (push (list method) result)))
36     (reduce #'append result)))
37
38 (defmethod compute-applicable-methods ((gf msl-generic-function) arguments)
39   (reverse-method-list (call-next-method)))
40 (defmethod compute-applicable-methods-using-classes
41     ((gf msl-generic-function) classes)
42   (reverse-method-list (call-next-method)))
43
44 (defgeneric testgf07 (x)
45   (:generic-function-class msl-generic-function)
46   (:method ((x integer))
47     (cons 'integer (if (next-method-p) (call-next-method))))
48   (:method ((x real))
49     (cons 'real (if (next-method-p) (call-next-method))))
50   (:method ((x number))
51     (cons 'number (if (next-method-p) (call-next-method))))
52   (:method :around ((x integer))
53     (coerce (call-next-method) 'vector)))
54
55 (assert (equalp (list (testgf07 5.0) (testgf07 17))
56                 '((number real) #(number real integer))))
57
58 (defclass nonumber-generic-function (standard-generic-function)
59   ()
60   (:metaclass funcallable-standard-class))
61
62 (defun nonumber-method-list (methods)
63   (remove-if #'(lambda (method)
64                  (member (find-class 'number)
65                          (sb-pcl:method-specializers method)))
66              methods))
67
68 (defmethod compute-applicable-methods
69     ((gf nonumber-generic-function) arguments)
70   (nonumber-method-list (call-next-method)))
71 (defmethod compute-applicable-methods-using-classes
72     ((gf nonumber-generic-function) classes)
73   (nonumber-method-list (call-next-method)))
74
75 (defgeneric testgf08 (x)
76   (:generic-function-class nonumber-generic-function)
77   (:method ((x integer))
78     (cons 'integer (if (next-method-p) (call-next-method))))
79   (:method ((x real))
80     (cons 'real (if (next-method-p) (call-next-method))))
81   (:method ((x number))
82     (cons 'number (if (next-method-p) (call-next-method))))
83   (:method :around ((x integer))
84     (coerce (call-next-method) 'vector)))
85
86 (assert (equalp (list (testgf08 5.0) (testgf08 17))
87                 '((real) #(integer real))))