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-function-type (generic-function form
68 method-alist-p wrappers-p)
70 (eq (car form) 'call-method))
71 (let* ((cm-args (cdr form))
72 (method (car cm-args)))
74 (if (if (listp method)
75 (eq (car method) ':early-method)
79 (multiple-value-bind (mf fmf)
81 (early-method-function method)
82 (values nil (method-fast-function method)))
84 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
85 (if (and fmf (or (null pv-table) wrappers-p))
88 (if (and (consp method) (eq (car method) 'make-method))
89 (make-effective-method-function-type
90 generic-function (cadr method) method-alist-p wrappers-p)
94 (defun make-effective-method-function-simple
95 (generic-function form &optional no-fmf-p)
96 ;; The effective method is just a call to call-method. This opens up
97 ;; the possibility of just using the method function of the method as
98 ;; the effective method function.
100 ;; But we have to be careful. If that method function will ask for
101 ;; the next methods we have to provide them. We do not look to see
102 ;; if there are next methods, we look at whether the method function
103 ;; asks about them. If it does, we must tell it whether there are
104 ;; or aren't to prevent the leaky next methods bug.
105 (let* ((cm-args (cdr form))
106 (fmf-p (and (null no-fmf-p)
107 (or (not (eq *boot-state* 'complete))
108 (gf-fast-method-function-p generic-function))
109 (null (cddr cm-args))))
110 (method (car cm-args))
111 (cm-args1 (cdr cm-args)))
112 #'(lambda (method-alist wrappers)
113 (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
114 method-alist wrappers))))
116 (defun make-emf-from-method
117 (method cm-args &optional gf fmf-p method-alist wrappers)
118 (multiple-value-bind (mf real-mf-p fmf pv-cell)
119 (get-method-function method method-alist wrappers)
121 (let* ((next-methods (car cm-args))
122 (next (make-effective-method-function-simple1
123 gf (car next-methods)
124 (list* (cdr next-methods) (cdr cm-args))
125 fmf-p method-alist wrappers))
126 (arg-info (method-function-get fmf ':arg-info)))
127 (make-fast-method-call :function fmf
129 :next-method-call next
132 (make-method-call :function mf
133 :call-method-args cm-args)
136 (defun make-effective-method-function-simple1
137 (gf method cm-args fmf-p &optional method-alist wrappers)
139 (if (if (listp method)
140 (eq (car method) ':early-method)
142 (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
143 (if (and (consp method) (eq (car method) 'make-method))
144 (make-effective-method-function gf
146 method-alist wrappers)
149 (defvar *global-effective-method-gensyms* ())
150 (defvar *rebound-effective-method-gensyms*)
152 (defun get-effective-method-gensym ()
153 (or (pop *rebound-effective-method-gensyms*)
154 (let ((new (intern (format nil
155 "EFFECTIVE-METHOD-GENSYM-~D"
156 (length *global-effective-method-gensyms*))
158 (setq *global-effective-method-gensyms*
159 (append *global-effective-method-gensyms* (list new)))
162 (let ((*rebound-effective-method-gensyms* ()))
163 (dotimes-fixnum (i 10) (get-effective-method-gensym)))
165 (defun expand-effective-method-function (gf effective-method &optional env)
166 (declare (ignore env))
167 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
168 (get-generic-function-info gf)
169 (declare (ignore nreq nkeys arg-info))
170 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
171 ;; When there are no primary methods and a next-method call occurs
172 ;; effective-method is (error "No mumble..") and the defined
173 ;; args are not used giving a compiler warning.
174 (error-p (eq (first effective-method) 'error)))
176 (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
177 ,effective-method))))
179 (defun expand-emf-call-method (gf form metatypes applyp env)
180 (declare (ignore gf metatypes applyp env))
181 `(call-method ,(cdr form)))
183 (defmacro call-method (&rest args)
184 (declare (ignore args))
185 `(error "~S outside of a effective method form" 'call-method))
187 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
188 (cond ((and (consp form) (eq (car form) 'call-method))
189 (case (make-effective-method-function-type
190 generic-function form method-alist-p wrappers-p)
195 ((and (consp form) (eq (car form) 'call-method-list))
196 (case (if (every #'(lambda (form)
197 (eq 'fast-method-call
198 (make-effective-method-function-type
199 generic-function form
200 method-alist-p wrappers-p)))
205 '.fast-call-method-list.)
207 '.call-method-list.)))
209 (default-test-converter form))))
211 (defun memf-code-converter
212 (form generic-function metatypes applyp method-alist-p wrappers-p)
213 (cond ((and (consp form) (eq (car form) 'call-method))
214 (let ((gensym (get-effective-method-gensym)))
215 (values (make-emf-call metatypes applyp gensym
216 (make-effective-method-function-type
217 generic-function form method-alist-p wrappers-p))
219 ((and (consp form) (eq (car form) 'call-method-list))
220 (let ((gensym (get-effective-method-gensym))
221 (type (if (every #'(lambda (form)
222 (eq 'fast-method-call
223 (make-effective-method-function-type
224 generic-function form
225 method-alist-p wrappers-p)))
229 (values `(dolist (emf ,gensym nil)
230 ,(make-emf-call metatypes applyp 'emf type))
233 (default-code-converter form))))
235 (defun memf-constant-converter (form generic-function)
236 (cond ((and (consp form) (eq (car form) 'call-method))
238 (make-effective-method-function-simple
239 generic-function form))))
240 ((and (consp form) (eq (car form) 'call-method-list))
241 (list (cons '.meth-list.
242 (mapcar #'(lambda (form)
243 (make-effective-method-function-simple
244 generic-function form))
247 (default-constant-converter form))))
249 (defun make-effective-method-function-internal
250 (generic-function effective-method method-alist-p wrappers-p)
251 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
252 (get-generic-function-info generic-function)
253 (declare (ignore nkeys arg-info))
254 (let* ((*rebound-effective-method-gensyms*
255 *global-effective-method-gensyms*)
256 (name (if (early-gf-p generic-function)
257 (early-gf-name generic-function)
258 (generic-function-name generic-function)))
259 (arg-info (cons nreq applyp))
260 (effective-method-lambda (expand-effective-method-function
261 generic-function effective-method)))
262 (multiple-value-bind (cfunction constants)
263 (get-function1 effective-method-lambda
265 (memf-test-converter form generic-function
266 method-alist-p wrappers-p))
268 (memf-code-converter form generic-function
270 method-alist-p wrappers-p))
272 (memf-constant-converter form generic-function)))
273 #'(lambda (method-alist wrappers)
275 (mapcar #'(lambda (constant)
279 (funcall (cdr constant)
280 method-alist wrappers))
282 (mapcar #'(lambda (fn)
290 (function (set-function-name
291 (apply cfunction constants)
292 `(combined-method ,name))))
293 (make-fast-method-call :function function
294 :arg-info arg-info)))))))
296 (defmacro call-method-list (&rest calls)
299 (defun make-call-methods (methods)
301 ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
303 (defun standard-compute-effective-method (generic-function combin applicable-methods)
304 (declare (ignore combin))
309 (dolist (m applicable-methods)
310 (let ((qualifiers (if (listp m)
311 (early-method-qualifiers m)
312 (method-qualifiers m))))
313 (cond ((member ':before qualifiers) (push m before))
314 ((member ':after qualifiers) (push m after))
315 ((member ':around qualifiers) (push m around))
318 (setq before (reverse before)
319 after (reverse after)
320 primary (reverse primary)
321 around (reverse around))
322 (cond ((null primary)
323 `(error "There is no primary method for the generic function ~S."
325 ((and (null before) (null after) (null around))
326 ;; By returning a single call-method `form' here we enable an
327 ;; important implementation-specific optimization.
328 `(call-method ,(first primary) ,(rest primary)))
330 (let ((main-effective-method
331 (if (or before after)
332 `(multiple-value-prog1
333 (progn ,(make-call-methods before)
334 (call-method ,(first primary)
336 ,(make-call-methods (reverse after)))
337 `(call-method ,(first primary) ,(rest primary)))))
339 `(call-method ,(first around)
341 (make-method ,main-effective-method)))
342 main-effective-method))))))
344 ;;;; the STANDARD method combination type. This is coded by hand (rather than
345 ;;;; with define-method-combination) for bootstrapping and efficiency reasons.
346 ;;;; Note that the definition of the find-method-combination-method appears in
347 ;;;; the file defcombin.lisp. This is because EQL methods can't appear in the
350 ;;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
351 ;;;; classes has to appear here for this reason. This code must conform to
352 ;;;; the code in the file defcombin.lisp, look there for more details.
354 (defun compute-effective-method (generic-function combin applicable-methods)
355 (standard-compute-effective-method generic-function
359 (defvar *invalid-method-error*
360 #'(lambda (&rest args)
361 (declare (ignore args))
363 "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
364 of a method combination function (inside the body of~%~
365 DEFINE-METHOD-COMBINATION or a method on the generic~%~
366 function COMPUTE-EFFECTIVE-METHOD).")))
368 (defvar *method-combination-error*
369 #'(lambda (&rest args)
370 (declare (ignore args))
372 "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
373 of a method combination function (inside the body of~%~
374 DEFINE-METHOD-COMBINATION or a method on the generic~%~
375 function COMPUTE-EFFECTIVE-METHOD).")))
377 ;(defmethod compute-effective-method :around ;issue with magic
378 ; ((generic-function generic-function) ;generic functions
379 ; (method-combination method-combination)
380 ; applicable-methods)
381 ; (declare (ignore applicable-methods))
382 ; (flet ((real-invalid-method-error (method format-string &rest args)
383 ; (declare (ignore method))
384 ; (apply #'error format-string args))
385 ; (real-method-combination-error (format-string &rest args)
386 ; (apply #'error format-string args)))
387 ; (let ((*invalid-method-error* #'real-invalid-method-error)
388 ; (*method-combination-error* #'real-method-combination-error))
389 ; (call-next-method))))
391 (defun invalid-method-error (&rest args)
392 (declare (arglist method format-string &rest format-arguments))
393 (apply *invalid-method-error* args))
395 (defun method-combination-error (&rest args)
396 (declare (arglist format-string &rest format-arguments))
397 (apply *method-combination-error* args))
399 ;This definition now appears in defcombin.lisp.
401 ;(defmethod find-method-combination ((generic-function generic-function)
402 ; (type (eql 'standard))
405 ; (method-combination-error
406 ; "The method combination type STANDARD accepts no options."))
407 ; *standard-method-combination*)