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 contains two tests for COMPUTE-APPLICABLE-METHODS on
15 ;;; subclasses of generic functions. However, at present it is
16 ;;; impossible to have both of these in the same image, because of a
17 ;;; vicious metacircle. Once the vicious metacircle is dealt with,
18 ;;; uncomment the second test case.
20 ;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
27 (defclass msl-generic-function (standard-generic-function)
29 (:metaclass funcallable-standard-class))
31 (defun reverse-method-list (methods)
33 (dolist (method methods)
34 (if (and (consp result)
35 (equal (method-qualifiers method)
36 (method-qualifiers (caar result))))
37 (push method (car result))
38 (push (list method) result)))
39 (reduce #'append result)))
41 (defmethod compute-applicable-methods ((gf msl-generic-function) arguments)
42 (reverse-method-list (call-next-method)))
43 (defmethod compute-applicable-methods-using-classes
44 ((gf msl-generic-function) classes)
45 (reverse-method-list (call-next-method)))
47 (defgeneric testgf07 (x)
48 (:generic-function-class msl-generic-function)
49 (:method ((x integer))
50 (cons 'integer (if (next-method-p) (call-next-method))))
52 (cons 'real (if (next-method-p) (call-next-method))))
54 (cons 'number (if (next-method-p) (call-next-method))))
55 (:method :around ((x integer))
56 (coerce (call-next-method) 'vector)))
58 (assert (equalp (list (testgf07 5.0) (testgf07 17))
59 '((number real) #(number real integer))))
62 (defclass nonumber-generic-function (standard-generic-function)
64 (:metaclass funcallable-standard-class))
66 (defun nonumber-method-list (methods)
67 (remove-if #'(lambda (method)
68 (member (find-class 'number)
69 (sb-pcl:method-specializers method)))
72 (defmethod compute-applicable-methods
73 ((gf nonumber-generic-function) arguments)
74 (nonumber-method-list (call-next-method)))
75 (defmethod compute-applicable-methods-using-classes
76 ((gf nonumber-generic-function) classes)
77 (nonumber-method-list (call-next-method)))
79 (defgeneric testgf08 (x)
80 (:generic-function-class nonumber-generic-function)
81 (:method ((x integer))
82 (cons 'integer (if (next-method-p) (call-next-method))))
84 (cons 'real (if (next-method-p) (call-next-method))))
86 (cons 'number (if (next-method-p) (call-next-method))))
87 (:method :around ((x integer))
88 (coerce (call-next-method) 'vector)))
90 (assert (equalp (list (testgf08 5.0) (testgf08 17))
91 '((real) #(integer real))))
94 (sb-ext:quit :unix-status 104)