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
29 (defun get-method-function (method &optional method-alist wrappers)
30 (let ((fn (cadr (assoc method method-alist))))
32 (values fn nil nil nil)
33 (multiple-value-bind (mf fmf)
35 (early-method-function method)
36 (values nil (method-fast-function method)))
37 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
38 (if (and fmf (or (null pv-table) wrappers))
39 (let* ((pv-wrappers (when pv-table
40 (pv-wrappers-from-all-wrappers
42 (pv-cell (when (and pv-table pv-wrappers)
43 (pv-table-lookup pv-table pv-wrappers))))
44 (values mf t fmf pv-cell))
46 (or mf (if (listp method)
48 (method-function-from-fast-function fmf))
49 (method-function method)))
52 (defun make-effective-method-function (generic-function form &optional
53 method-alist wrappers)
54 (funcall (make-effective-method-function1 generic-function form
55 (not (null method-alist))
56 (not (null wrappers)))
57 method-alist wrappers))
59 (defun make-effective-method-function1 (generic-function form
60 method-alist-p wrappers-p)
62 (eq (car form) 'call-method))
63 (make-effective-method-function-simple generic-function form)
64 ;; We have some sort of `real' effective method. Go off and get a
65 ;; compiled function for it. Most of the real hair here is done by
66 ;; the GET-FUNCTION mechanism.
67 (make-effective-method-function-internal generic-function form
68 method-alist-p wrappers-p)))
70 (defun make-effective-method-function-type (generic-function form
71 method-alist-p wrappers-p)
73 (eq (car form) 'call-method))
74 (let* ((cm-args (cdr form))
75 (method (car cm-args)))
77 (if (if (listp method)
78 (eq (car method) ':early-method)
82 (multiple-value-bind (mf fmf)
84 (early-method-function method)
85 (values nil (method-fast-function method)))
87 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
88 (if (and fmf (or (null pv-table) wrappers-p))
91 (if (and (consp method) (eq (car method) 'make-method))
92 (make-effective-method-function-type
93 generic-function (cadr method) method-alist-p wrappers-p)
97 (defun make-effective-method-function-simple
98 (generic-function form &optional no-fmf-p)
99 ;; The effective method is just a call to call-method. This opens up
100 ;; the possibility of just using the method function of the method as
101 ;; the effective method function.
103 ;; But we have to be careful. If that method function will ask for
104 ;; the next methods we have to provide them. We do not look to see
105 ;; if there are next methods, we look at whether the method function
106 ;; asks about them. If it does, we must tell it whether there are
107 ;; or aren't to prevent the leaky next methods bug.
108 (let* ((cm-args (cdr form))
109 (fmf-p (and (null no-fmf-p)
110 (or (not (eq *boot-state* 'complete))
111 (gf-fast-method-function-p generic-function))
112 (null (cddr cm-args))))
113 (method (car cm-args))
114 (cm-args1 (cdr cm-args)))
115 #'(lambda (method-alist wrappers)
116 (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
117 method-alist wrappers))))
119 (defun make-emf-from-method
120 (method cm-args &optional gf fmf-p method-alist wrappers)
121 (multiple-value-bind (mf real-mf-p fmf pv-cell)
122 (get-method-function method method-alist wrappers)
124 (let* ((next-methods (car cm-args))
125 (next (make-effective-method-function-simple1
126 gf (car next-methods)
127 (list* (cdr next-methods) (cdr cm-args))
128 fmf-p method-alist wrappers))
129 (arg-info (method-function-get fmf ':arg-info)))
130 (make-fast-method-call :function fmf
132 :next-method-call next
135 (make-method-call :function mf
136 :call-method-args cm-args)
139 (defun make-effective-method-function-simple1
140 (gf method cm-args fmf-p &optional method-alist wrappers)
142 (if (if (listp method)
143 (eq (car method) ':early-method)
145 (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
146 (if (and (consp method) (eq (car method) 'make-method))
147 (make-effective-method-function gf
149 method-alist wrappers)
152 (defvar *global-effective-method-gensyms* ())
153 (defvar *rebound-effective-method-gensyms*)
155 (defun get-effective-method-gensym ()
156 (or (pop *rebound-effective-method-gensyms*)
157 (let ((new (intern (format nil
158 "EFFECTIVE-METHOD-GENSYM-~D"
159 (length *global-effective-method-gensyms*))
161 (setq *global-effective-method-gensyms*
162 (append *global-effective-method-gensyms* (list new)))
165 (let ((*rebound-effective-method-gensyms* ()))
166 (dotimes-fixnum (i 10) (get-effective-method-gensym)))
168 (defun expand-effective-method-function (gf effective-method &optional env)
169 (declare (ignore env))
170 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
171 (get-generic-function-info gf)
172 (declare (ignore nreq nkeys arg-info))
173 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
174 ;; When there are no primary methods and a next-method call occurs
175 ;; effective-method is (error "No mumble..") and the defined
176 ;; args are not used giving a compiler warning.
177 (error-p (eq (first effective-method) 'error)))
179 (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
180 ,effective-method))))
182 (defun expand-emf-call-method (gf form metatypes applyp env)
183 (declare (ignore gf metatypes applyp env))
184 `(call-method ,(cdr form)))
186 (defmacro call-method (&rest args)
187 (declare (ignore args))
188 `(error "~S outside of a effective method form" 'call-method))
190 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
191 (cond ((and (consp form) (eq (car form) 'call-method))
192 (case (make-effective-method-function-type
193 generic-function form method-alist-p wrappers-p)
198 ((and (consp form) (eq (car form) 'call-method-list))
199 (case (if (every #'(lambda (form)
200 (eq 'fast-method-call
201 (make-effective-method-function-type
202 generic-function form
203 method-alist-p wrappers-p)))
208 '.fast-call-method-list.)
210 '.call-method-list.)))
212 (default-test-converter form))))
214 (defun memf-code-converter
215 (form generic-function metatypes applyp method-alist-p wrappers-p)
216 (cond ((and (consp form) (eq (car form) 'call-method))
217 (let ((gensym (get-effective-method-gensym)))
218 (values (make-emf-call metatypes applyp gensym
219 (make-effective-method-function-type
220 generic-function form method-alist-p wrappers-p))
222 ((and (consp form) (eq (car form) 'call-method-list))
223 (let ((gensym (get-effective-method-gensym))
224 (type (if (every #'(lambda (form)
225 (eq 'fast-method-call
226 (make-effective-method-function-type
227 generic-function form
228 method-alist-p wrappers-p)))
232 (values `(dolist (emf ,gensym nil)
233 ,(make-emf-call metatypes applyp 'emf type))
236 (default-code-converter form))))
238 (defun memf-constant-converter (form generic-function)
239 (cond ((and (consp form) (eq (car form) 'call-method))
241 (make-effective-method-function-simple
242 generic-function form))))
243 ((and (consp form) (eq (car form) 'call-method-list))
244 (list (cons '.meth-list.
245 (mapcar #'(lambda (form)
246 (make-effective-method-function-simple
247 generic-function form))
250 (default-constant-converter form))))
252 (defun make-effective-method-function-internal
253 (generic-function effective-method method-alist-p wrappers-p)
254 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
255 (get-generic-function-info generic-function)
256 (declare (ignore nkeys arg-info))
257 (let* ((*rebound-effective-method-gensyms*
258 *global-effective-method-gensyms*)
259 (name (if (early-gf-p generic-function)
260 (early-gf-name generic-function)
261 (generic-function-name generic-function)))
262 (arg-info (cons nreq applyp))
263 (effective-method-lambda (expand-effective-method-function
264 generic-function effective-method)))
265 (multiple-value-bind (cfunction constants)
266 (get-function1 effective-method-lambda
268 (memf-test-converter form generic-function
269 method-alist-p wrappers-p))
271 (memf-code-converter form generic-function
273 method-alist-p wrappers-p))
275 (memf-constant-converter form generic-function)))
276 #'(lambda (method-alist wrappers)
278 (mapcar #'(lambda (constant)
282 (funcall (cdr constant)
283 method-alist wrappers))
285 (mapcar #'(lambda (fn)
293 (function (set-function-name
294 (apply cfunction constants)
295 `(combined-method ,name))))
296 (make-fast-method-call :function function
297 :arg-info arg-info)))))))
299 (defmacro call-method-list (&rest calls)
302 (defun make-call-methods (methods)
304 ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
306 (defun standard-compute-effective-method (generic-function combin applicable-methods)
307 (declare (ignore combin))
312 (dolist (m applicable-methods)
313 (let ((qualifiers (if (listp m)
314 (early-method-qualifiers m)
315 (method-qualifiers m))))
316 (cond ((member ':before qualifiers) (push m before))
317 ((member ':after qualifiers) (push m after))
318 ((member ':around qualifiers) (push m around))
321 (setq before (reverse before)
322 after (reverse after)
323 primary (reverse primary)
324 around (reverse around))
325 (cond ((null primary)
326 `(error "There is no primary method for the generic function ~S."
328 ((and (null before) (null after) (null around))
329 ;; By returning a single call-method `form' here we enable an
330 ;; important implementation-specific optimization.
331 `(call-method ,(first primary) ,(rest primary)))
333 (let ((main-effective-method
334 (if (or before after)
335 `(multiple-value-prog1
336 (progn ,(make-call-methods before)
337 (call-method ,(first primary)
339 ,(make-call-methods (reverse after)))
340 `(call-method ,(first primary) ,(rest primary)))))
342 `(call-method ,(first around)
344 (make-method ,main-effective-method)))
345 main-effective-method))))))
347 ;;;; the STANDARD method combination type. This is coded by hand (rather than
348 ;;;; with define-method-combination) for bootstrapping and efficiency reasons.
349 ;;;; Note that the definition of the find-method-combination-method appears in
350 ;;;; the file defcombin.lisp. This is because EQL methods can't appear in the
353 ;;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
354 ;;;; classes has to appear here for this reason. This code must conform to
355 ;;;; the code in the file defcombin.lisp, look there for more details.
357 (defun compute-effective-method (generic-function combin applicable-methods)
358 (standard-compute-effective-method generic-function
362 (defvar *invalid-method-error*
363 #'(lambda (&rest args)
364 (declare (ignore args))
366 "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
367 of a method combination function (inside the body of~%~
368 DEFINE-METHOD-COMBINATION or a method on the generic~%~
369 function COMPUTE-EFFECTIVE-METHOD).")))
371 (defvar *method-combination-error*
372 #'(lambda (&rest args)
373 (declare (ignore args))
375 "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
376 of a method combination function (inside the body of~%~
377 DEFINE-METHOD-COMBINATION or a method on the generic~%~
378 function COMPUTE-EFFECTIVE-METHOD).")))
380 ;(defmethod compute-effective-method :around ;issue with magic
381 ; ((generic-function generic-function) ;generic functions
382 ; (method-combination method-combination)
383 ; applicable-methods)
384 ; (declare (ignore applicable-methods))
385 ; (flet ((real-invalid-method-error (method format-string &rest args)
386 ; (declare (ignore method))
387 ; (apply #'error format-string args))
388 ; (real-method-combination-error (format-string &rest args)
389 ; (apply #'error format-string args)))
390 ; (let ((*invalid-method-error* #'real-invalid-method-error)
391 ; (*method-combination-error* #'real-method-combination-error))
392 ; (call-next-method))))
394 (defun invalid-method-error (&rest args)
395 (declare (arglist method format-string &rest format-arguments))
396 (apply *invalid-method-error* args))
398 (defun method-combination-error (&rest args)
399 (declare (arglist format-string &rest format-arguments))
400 (apply *method-combination-error* args))
402 ;This definition now appears in defcombin.lisp.
404 ;(defmethod find-method-combination ((generic-function generic-function)
405 ; (type (eql 'standard))
408 ; (method-combination-error
409 ; "The method combination type STANDARD accepts no options."))
410 ; *standard-method-combination*)