1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 (defun get-method-function (method &optional method-alist wrappers)
27 (let ((fn (cadr (assoc method method-alist))))
29 (values fn nil nil nil)
30 (multiple-value-bind (mf fmf)
32 (early-method-function method)
33 (values nil (method-fast-function method)))
34 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
35 (if (and fmf (or (null pv-table) wrappers))
36 (let* ((pv-wrappers (when pv-table
37 (pv-wrappers-from-all-wrappers
39 (pv-cell (when (and pv-table pv-wrappers)
40 (pv-table-lookup pv-table pv-wrappers))))
41 (values mf t fmf pv-cell))
43 (or mf (if (listp method)
45 (method-function-from-fast-function fmf))
46 (method-function method)))
49 (defun make-effective-method-function (generic-function form &optional
50 method-alist wrappers)
51 (funcall (make-effective-method-function1 generic-function form
52 (not (null method-alist))
53 (not (null wrappers)))
54 method-alist wrappers))
56 (defun make-effective-method-function1 (generic-function form
57 method-alist-p wrappers-p)
59 (eq (car form) 'call-method))
60 (make-effective-method-function-simple generic-function form)
61 ;; We have some sort of `real' effective method. Go off and get a
62 ;; compiled function for it. Most of the real hair here is done by
63 ;; the GET-FUNCTION mechanism.
64 (make-effective-method-function-internal generic-function form
65 method-alist-p wrappers-p)))
67 (defun make-effective-method-fun-type (generic-function
72 (eq (car form) 'call-method))
73 (let* ((cm-args (cdr form))
74 (method (car cm-args)))
76 (if (if (listp method)
77 (eq (car method) ':early-method)
81 (multiple-value-bind (mf fmf)
83 (early-method-function method)
84 (values nil (method-fast-function method)))
86 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
87 (if (and fmf (or (null pv-table) wrappers-p))
90 (if (and (consp method) (eq (car method) 'make-method))
91 (make-effective-method-fun-type
92 generic-function (cadr method) method-alist-p wrappers-p)
96 (defun make-effective-method-function-simple
97 (generic-function form &optional no-fmf-p)
98 ;; The effective method is just a call to call-method. This opens up
99 ;; the possibility of just using the method function of the method as
100 ;; the effective method function.
102 ;; But we have to be careful. If that method function will ask for
103 ;; the next methods we have to provide them. We do not look to see
104 ;; if there are next methods, we look at whether the method function
105 ;; asks about them. If it does, we must tell it whether there are
106 ;; or aren't to prevent the leaky next methods bug.
107 (let* ((cm-args (cdr form))
108 (fmf-p (and (null no-fmf-p)
109 (or (not (eq *boot-state* 'complete))
110 (gf-fast-method-function-p generic-function))
111 (null (cddr cm-args))))
112 (method (car cm-args))
113 (cm-args1 (cdr cm-args)))
114 #'(lambda (method-alist wrappers)
115 (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
116 method-alist wrappers))))
118 (defun make-emf-from-method
119 (method cm-args &optional gf fmf-p method-alist wrappers)
120 (multiple-value-bind (mf real-mf-p fmf pv-cell)
121 (get-method-function method method-alist wrappers)
123 (let* ((next-methods (car cm-args))
124 (next (make-effective-method-function-simple1
125 gf (car next-methods)
126 (list* (cdr next-methods) (cdr cm-args))
127 fmf-p method-alist wrappers))
128 (arg-info (method-function-get fmf ':arg-info)))
129 (make-fast-method-call :function fmf
131 :next-method-call next
134 (make-method-call :function mf
135 :call-method-args cm-args)
138 (defun make-effective-method-function-simple1
139 (gf method cm-args fmf-p &optional method-alist wrappers)
141 (if (if (listp method)
142 (eq (car method) ':early-method)
144 (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
145 (if (and (consp method) (eq (car method) 'make-method))
146 (make-effective-method-function gf
148 method-alist wrappers)
151 (defvar *global-effective-method-gensyms* ())
152 (defvar *rebound-effective-method-gensyms*)
154 (defun get-effective-method-gensym ()
155 (or (pop *rebound-effective-method-gensyms*)
156 (let ((new (intern (format nil
157 "EFFECTIVE-METHOD-GENSYM-~D"
158 (length *global-effective-method-gensyms*))
160 (setq *global-effective-method-gensyms*
161 (append *global-effective-method-gensyms* (list new)))
164 (let ((*rebound-effective-method-gensyms* ()))
165 (dotimes-fixnum (i 10) (get-effective-method-gensym)))
167 (defun expand-effective-method-function (gf effective-method &optional env)
168 (declare (ignore env))
169 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
170 (get-generic-function-info gf)
171 (declare (ignore nreq nkeys arg-info))
172 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
173 ;; When there are no primary methods and a next-method call occurs
174 ;; effective-method is (error "No mumble..") and the defined
175 ;; args are not used giving a compiler warning.
176 (error-p (eq (first effective-method) 'error)))
178 (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
179 ,effective-method))))
181 (defun expand-emf-call-method (gf form metatypes applyp env)
182 (declare (ignore gf metatypes applyp env))
183 `(call-method ,(cdr form)))
185 (defmacro call-method (&rest args)
186 (declare (ignore args))
187 `(error "~S outside of a effective method form" 'call-method))
189 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
190 (cond ((and (consp form) (eq (car form) 'call-method))
191 (case (make-effective-method-fun-type
192 generic-function form method-alist-p wrappers-p)
197 ((and (consp form) (eq (car form) 'call-method-list))
198 (case (if (every #'(lambda (form)
199 (eq 'fast-method-call
200 (make-effective-method-fun-type
201 generic-function form
202 method-alist-p wrappers-p)))
207 '.fast-call-method-list.)
209 '.call-method-list.)))
211 (default-test-converter form))))
213 (defun memf-code-converter
214 (form generic-function metatypes applyp method-alist-p wrappers-p)
215 (cond ((and (consp form) (eq (car form) 'call-method))
216 (let ((gensym (get-effective-method-gensym)))
217 (values (make-emf-call metatypes applyp gensym
218 (make-effective-method-fun-type
219 generic-function form method-alist-p wrappers-p))
221 ((and (consp form) (eq (car form) 'call-method-list))
222 (let ((gensym (get-effective-method-gensym))
223 (type (if (every #'(lambda (form)
224 (eq 'fast-method-call
225 (make-effective-method-fun-type
226 generic-function form
227 method-alist-p wrappers-p)))
231 (values `(dolist (emf ,gensym nil)
232 ,(make-emf-call metatypes applyp 'emf type))
235 (default-code-converter form))))
237 (defun memf-constant-converter (form generic-function)
238 (cond ((and (consp form) (eq (car form) 'call-method))
240 (make-effective-method-function-simple
241 generic-function form))))
242 ((and (consp form) (eq (car form) 'call-method-list))
243 (list (cons '.meth-list.
244 (mapcar #'(lambda (form)
245 (make-effective-method-function-simple
246 generic-function form))
249 (default-constant-converter form))))
251 (defun make-effective-method-function-internal
252 (generic-function effective-method method-alist-p wrappers-p)
253 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
254 (get-generic-function-info generic-function)
255 (declare (ignore nkeys arg-info))
256 (let* ((*rebound-effective-method-gensyms*
257 *global-effective-method-gensyms*)
258 (name (if (early-gf-p generic-function)
259 (!early-gf-name generic-function)
260 (generic-function-name generic-function)))
261 (arg-info (cons nreq applyp))
262 (effective-method-lambda (expand-effective-method-function
263 generic-function effective-method)))
264 (multiple-value-bind (cfunction constants)
265 (get-function1 effective-method-lambda
267 (memf-test-converter form generic-function
268 method-alist-p wrappers-p))
270 (memf-code-converter form generic-function
272 method-alist-p wrappers-p))
274 (memf-constant-converter form generic-function)))
275 #'(lambda (method-alist wrappers)
277 (mapcar #'(lambda (constant)
281 (funcall (cdr constant)
282 method-alist wrappers))
284 (mapcar #'(lambda (fn)
292 (function (set-fun-name
293 (apply cfunction constants)
294 `(combined-method ,name))))
295 (make-fast-method-call :function function
296 :arg-info arg-info)))))))
298 (defmacro call-method-list (&rest calls)
301 (defun make-call-methods (methods)
303 ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
305 (defun standard-compute-effective-method (generic-function combin applicable-methods)
306 (declare (ignore combin))
311 (flet ((lose (method why)
312 (invalid-method-error
314 "The method ~S ~A.~%~
315 Standard method combination requires all methods to have one~%~
316 of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
317 have no qualifier at all."
319 (dolist (m applicable-methods)
320 (let ((qualifiers (if (listp m)
321 (early-method-qualifiers m)
322 (method-qualifiers m))))
324 ((null qualifiers) (push m primary))
326 (lose m "has more than one qualifier"))
327 ((eq (car qualifiers) :around)
329 ((eq (car qualifiers) :before)
331 ((eq (car qualifiers) :after)
334 (lose m "has an illegal qualifier"))))))
335 (setq before (reverse before)
336 after (reverse after)
337 primary (reverse primary)
338 around (reverse around))
339 (cond ((null primary)
340 `(error "There is no primary method for the generic function ~S."
342 ((and (null before) (null after) (null around))
343 ;; By returning a single call-method `form' here we enable an
344 ;; important implementation-specific optimization.
345 `(call-method ,(first primary) ,(rest primary)))
347 (let ((main-effective-method
348 (if (or before after)
349 `(multiple-value-prog1
350 (progn ,(make-call-methods before)
351 (call-method ,(first primary)
353 ,(make-call-methods (reverse after)))
354 `(call-method ,(first primary) ,(rest primary)))))
356 `(call-method ,(first around)
358 (make-method ,main-effective-method)))
359 main-effective-method))))))
361 ;;;; the STANDARD method combination type. This is coded by hand
362 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
363 ;;;; and efficiency reasons. Note that the definition of the
364 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
365 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
368 ;;;; The DEFCLASS for the METHOD-COMBINATION and
369 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
370 ;;;; reason. This code must conform to the code in the file
371 ;;;; defcombin.lisp, look there for more details.
373 (defun compute-effective-method (generic-function combin applicable-methods)
374 (standard-compute-effective-method generic-function
378 (defun invalid-method-error (method format-control &rest format-arguments)
379 (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
384 (defun method-combination-error (format-control &rest format-arguments)
385 (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"