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 ;;; Pascal Costanza's implementation of beta methods, lightly
15 ;;; modified. Contains a specialization of MAKE-METHOD-LAMBDA.
17 (defclass beta-generic-function
(standard-generic-function)
19 (:metaclass sb-mop
:funcallable-standard-class
))
21 (defclass beta-method
(standard-method)
22 ((betap :reader betap
:initarg
:betap
:initform nil
)))
24 (defmethod initialize-instance :around
25 ((method beta-method
) &rest initargs
&key qualifiers
)
26 (declare (dynamic-extent initargs
))
27 (if (equal qualifiers
'(:beta
))
28 (apply #'call-next-method method
34 (defun collect-runs (methods)
35 (let ((complete-runs nil
)
37 (flet ((complete-run ()
39 (push (nreverse current-run
) complete-runs
)
40 (setf current-run nil
))))
41 (loop for method in methods with seen-beta
= nil do
45 (setq seen-beta t current-run nil
)))
46 (push method current-run
))
50 (define-method-combination beta
()
53 (primary () :required t
)
55 (flet ((call-methods (methods)
56 (mapcar (lambda (method) `(call-method ,method
)) methods
)))
57 (let ((form (if (or before after
(rest primary
))
58 (let ((runs (collect-runs primary
)))
59 `(multiple-value-prog1
61 ,@(call-methods before
)
62 (call-method ,(first (first runs
))
65 ,@(call-methods (reverse after
))))
66 `(call-method ,(first primary
)))))
68 `(call-method ,(first around
) (,@(rest around
) (make-method ,form
)))
71 (defmethod sb-mop:make-method-lambda
72 ((gf beta-generic-function
) method-prototype lambda-expression environment
)
73 (declare (ignore method-prototype environment
))
74 (let ((method-args (gensym))
75 (next-methods (gensym))
76 (inner-runs (gensym)))
77 `(lambda (,method-args
&optional
,next-methods
,inner-runs
)
78 (declare (ignorable ,next-methods
,inner-runs
))
79 (flet ((call-next-method (&rest args
)
80 (declare (dynamic-extent args
))
81 (if (null ,next-methods
)
82 (error "There is no next method for ~S." ,gf
)
83 (funcall (sb-mop:method-function
(car ,next-methods
))
84 (if args args
,method-args
)
87 (next-method-p () (not (null ,next-methods
)))
88 (call-inner-method (&rest args
)
89 (declare (dynamic-extent args
))
90 (if (null ,inner-runs
)
91 (error "There is no inner method for ~S." ,gf
)
92 (funcall (sb-mop:method-function
(caar ,inner-runs
))
93 (if args args
,method-args
)
96 (inner-method-p () (not (null ,inner-runs
))))
97 (declare (ignorable #'call-next-method
#'next-method-p
98 #'call-inner-method
#'inner-method-p
))
99 (apply ,lambda-expression
,method-args
)))))
101 (defmacro define-beta-function
(name (&rest args
) &rest options
)
102 `(defgeneric ,name
,args
103 ,@(unless (member :generic-function-class options
:key
#'car
)
104 '((:generic-function-class beta-generic-function
)))
105 ,@(unless (member :method-class options
:key
#'car
)
106 '((:method-class beta-method
)))
107 ,@(unless (member :method-combination options
:key
#'car
)
108 '((:method-combination beta
)))
112 (defclass middle
(top) ())
113 (defclass bottom
(middle) ())
115 (define-beta-function test
(object))
117 ;;; MAKE-METHOD-LAMBDA acts at (DEFMETHOD-)expand-time, which is
118 ;;; before DEFCLASS- and DEFGENERIC-load-time.
121 '(defmethod test ((object top
))
122 (declare (ignore object
))
124 '(defmethod test :beta
((object middle
))
125 (declare (ignore object
))
126 (list 'middle
(call-inner-method) (call-next-method)))
127 '(defmethod test :beta
((object bottom
))
128 (declare (ignore object
))
131 (with-test (:name
(:mop-21
))
132 (assert (equal '(middle bottom top
) (test (make-instance 'bottom
))))
133 (assert (equal 'top
(test (make-instance 'top
))))
134 (assert (null (ignore-errors (test (make-instance 'middle
))))))