1 |
|
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
|
28 |
|
(in-package :pcl) |
29 |
|
|
30 |
|
(defun get-method-function (method &optional method-alist wrappers) |
31 |
|
(let ((fn (cadr (assoc method method-alist)))) |
32 |
|
(if fn |
33 |
|
(values fn nil nil nil) |
34 |
|
(multiple-value-bind (mf fmf) |
35 |
|
(if (listp method) |
36 |
|
(early-method-function method) |
37 |
|
(values nil (method-fast-function method))) |
38 |
|
(let* ((pv-table (and fmf (method-function-pv-table fmf)))) |
39 |
|
(if (and fmf (or (null pv-table) wrappers)) |
40 |
|
(let* ((pv-wrappers (when pv-table |
41 |
|
(pv-wrappers-from-all-wrappers |
42 |
|
pv-table wrappers))) |
43 |
|
(pv-cell (when (and pv-table pv-wrappers) |
44 |
|
(pv-table-lookup pv-table pv-wrappers)))) |
45 |
|
(values mf t fmf pv-cell)) |
46 |
|
(values |
47 |
|
(or mf (if (listp method) |
48 |
|
(setf (cadr method) |
49 |
|
(method-function-from-fast-function fmf)) |
50 |
|
(method-function method))) |
51 |
|
t nil nil))))))) |
52 |
|
|
53 |
|
(defun make-effective-method-function (generic-function form &optional |
54 |
|
method-alist wrappers) |
55 |
|
(funcall (the function |
56 |
|
(make-effective-method-function1 generic-function form |
57 |
|
(not (null method-alist)) |
58 |
|
(not (null wrappers)))) |
59 |
|
method-alist wrappers)) |
60 |
|
|
61 |
|
(defun make-effective-method-function1 (generic-function form |
62 |
|
method-alist-p wrappers-p) |
63 |
|
(if (and (listp form) |
64 |
|
(eq (car form) 'call-method)) |
65 |
|
(make-effective-method-function-simple generic-function form) |
66 |
|
;; |
67 |
|
;; We have some sort of `real' effective method. Go off and get a |
68 |
|
;; compiled function for it. Most of the real hair here is done by |
69 |
|
;; the GET-FUNCTION mechanism. |
70 |
|
;; |
71 |
|
(make-effective-method-function-internal generic-function form |
72 |
|
method-alist-p wrappers-p))) |
73 |
|
|
74 |
|
(defun make-effective-method-function-type (generic-function form |
75 |
|
method-alist-p wrappers-p) |
76 |
|
(if (and (listp form) |
77 |
|
(eq (car form) 'call-method)) |
78 |
|
(let* ((cm-args (cdr form)) |
79 |
|
(method (car cm-args))) |
80 |
|
(when method |
81 |
|
(if (if (listp method) |
82 |
|
(eq (car method) ':early-method) |
83 |
|
(method-p method)) |
84 |
|
(if method-alist-p |
85 |
|
't |
86 |
|
(multiple-value-bind (mf fmf) |
87 |
|
(if (listp method) |
88 |
|
(early-method-function method) |
89 |
|
(values nil (method-fast-function method))) |
90 |
|
(declare (ignore mf)) |
91 |
|
(let* ((pv-table (and fmf (method-function-pv-table fmf)))) |
92 |
|
(if (and fmf (or (null pv-table) wrappers-p)) |
93 |
|
'fast-method-call |
94 |
|
'method-call)))) |
95 |
|
(if (and (consp method) (eq (car method) 'make-method)) |
96 |
|
(make-effective-method-function-type |
97 |
|
generic-function (cadr method) method-alist-p wrappers-p) |
98 |
|
(type-of method))))) |
99 |
|
'fast-method-call)) |
100 |
|
|
101 |
|
(defun make-effective-method-function-simple (generic-function form |
102 |
|
&optional no-fmf-p) |
103 |
|
;; |
104 |
|
;; The effective method is just a call to call-method. This opens up |
105 |
|
;; the possibility of just using the method function of the method as |
106 |
|
;; the effective method function. |
107 |
|
;; |
108 |
|
;; But we have to be careful. If that method function will ask for |
109 |
|
;; the next methods we have to provide them. We do not look to see |
110 |
|
;; if there are next methods, we look at whether the method function |
111 |
|
;; asks about them. If it does, we must tell it whether there are |
112 |
|
;; or aren't to prevent the leaky next methods bug. |
113 |
|
;; |
114 |
|
(let* ((cm-args (cdr form)) |
115 |
|
(fmf-p (and (null no-fmf-p) |
116 |
|
(or (not (eq *boot-state* 'complete)) |
117 |
|
(gf-fast-method-function-p generic-function)) |
118 |
|
(null (cddr cm-args)))) |
119 |
|
(method (car cm-args)) |
120 |
|
(cm-args1 (cdr cm-args))) |
121 |
|
#'(lambda (method-alist wrappers) |
122 |
|
(make-effective-method-function-simple1 generic-function method cm-args1 fmf-p |
123 |
|
method-alist wrappers)))) |
124 |
|
|
125 |
|
(defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) |
126 |
|
(multiple-value-bind (mf real-mf-p fmf pv-cell) |
127 |
|
(get-method-function method method-alist wrappers) |
128 |
|
(if fmf |
129 |
|
(let* ((next-methods (car cm-args)) |
130 |
|
(next (make-effective-method-function-simple1 |
131 |
|
gf (car next-methods) |
132 |
|
(list* (cdr next-methods) (cdr cm-args)) |
133 |
|
fmf-p method-alist wrappers)) |
134 |
|
(arg-info (method-function-get fmf ':arg-info))) |
135 |
|
(make-fast-method-call :function fmf |
136 |
|
:pv-cell pv-cell |
137 |
|
:next-method-call next |
138 |
|
:arg-info arg-info)) |
139 |
|
(if real-mf-p |
140 |
|
(make-method-call :function mf |
141 |
|
:call-method-args cm-args) |
142 |
|
mf)))) |
143 |
|
|
144 |
|
(defun make-effective-method-function-simple1 (gf method cm-args fmf-p |
145 |
|
&optional method-alist wrappers) |
146 |
|
(when method |
147 |
|
(if (if (listp method) |
148 |
|
(eq (car method) ':early-method) |
149 |
|
(method-p method)) |
150 |
|
(make-emf-from-method method cm-args gf fmf-p method-alist wrappers) |
151 |
|
(if (and (consp method) (eq (car method) 'make-method)) |
152 |
|
(make-effective-method-function gf (cadr method) method-alist wrappers) |
153 |
|
method)))) |
154 |
|
|
155 |
|
(defvar *global-effective-method-gensyms* ()) |
156 |
|
(defvar *rebound-effective-method-gensyms*) |
157 |
|
|
158 |
|
(defun get-effective-method-gensym () |
159 |
|
(or (pop *rebound-effective-method-gensyms*) |
160 |
|
(let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" |
161 |
|
(length *global-effective-method-gensyms*)) |
162 |
|
"PCL"))) |
163 |
|
(setq *global-effective-method-gensyms* |
164 |
|
(append *global-effective-method-gensyms* (list new))) |
165 |
|
new))) |
166 |
|
|
167 |
|
(let ((*rebound-effective-method-gensyms* ())) |
168 |
|
(dotimes (i 10) (get-effective-method-gensym))) |
169 |
|
|
170 |
|
(defun expand-effective-method-function (gf effective-method &optional env) |
171 |
|
(declare (ignore env)) |
172 |
|
(multiple-value-bind (nreq applyp metatypes nkeys arg-info) |
173 |
|
(get-generic-function-info gf) |
174 |
|
(declare (ignore nreq nkeys arg-info)) |
175 |
|
(let ((ll (make-fast-method-call-lambda-list metatypes applyp))) |
176 |
|
(cond |
177 |
|
;; When there are no primary methods and a next-method call |
178 |
|
;; occurs effective-method is (%no-primary-method <gf>), |
179 |
|
;; which we define here to collect all gf arguments, to pass |
180 |
|
;; those together with the GF to no-primary-method: |
181 |
|
((eq (first effective-method) '%no-primary-method) |
182 |
|
`(lambda (.pv-cell. .next-method-call. &rest .args.) |
183 |
|
(declare (ignore .pv-cell. .next-method-call.)) |
184 |
|
(flet ((%no-primary-method (gf) |
185 |
|
(apply #'no-primary-method gf .args.))) |
186 |
|
,effective-method))) |
187 |
|
;; When the method combination uses the :arguments option |
188 |
|
((and (eq *boot-state* 'complete) |
189 |
|
;; Otherwise the METHOD-COMBINATION slot is not bound. |
190 |
|
(let ((combin (generic-function-method-combination gf))) |
191 |
|
(and (long-method-combination-p combin) |
192 |
|
(long-method-combination-arguments-lambda-list combin)))) |
193 |
|
(let* ((required (dfun-arg-symbol-list metatypes)) |
194 |
|
(gf-args (if applyp |
195 |
|
`(list* ,@required .dfun-rest-arg.) |
196 |
|
`(list ,@required)))) |
197 |
|
`(lambda ,ll |
198 |
|
(declare (ignore .pv-cell. .next-method-call.)) |
199 |
|
(let ((.gf-args. ,gf-args)) |
200 |
|
(declare (ignorable .gf-args.)) |
201 |
|
,effective-method)))) |
202 |
|
(t |
203 |
|
`(lambda ,ll |
204 |
|
(declare (ignore .pv-cell. .next-method-call.)) |
205 |
|
,effective-method)))))) |
206 |
|
|
207 |
|
(defun expand-emf-call-method (gf form metatypes applyp env) |
208 |
|
(declare (ignore gf metatypes applyp env)) |
209 |
|
`(call-method ,(cdr form))) |
210 |
|
|
211 |
|
(defmacro call-method (&rest args) |
212 |
|
(declare (ignore args)) |
213 |
|
`(error "~S outside of an effective method form" 'call-method)) |
214 |
|
|
215 |
|
(defun memf-test-converter (form generic-function method-alist-p wrappers-p) |
216 |
|
(cond ((and (consp form) (eq (car form) 'call-method)) |
217 |
|
(case (make-effective-method-function-type |
218 |
|
generic-function form method-alist-p wrappers-p) |
219 |
|
(fast-method-call |
220 |
|
'.fast-call-method.) |
221 |
|
(t |
222 |
|
'.call-method.))) |
223 |
|
((and (consp form) (eq (car form) 'call-method-list)) |
224 |
|
(case (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))) |
229 |
|
(cdr form)) |
230 |
|
'fast-method-call |
231 |
|
't) |
232 |
|
(fast-method-call |
233 |
|
'.fast-call-method-list.) |
234 |
|
(t |
235 |
|
'.call-method-list.))) |
236 |
|
(t |
237 |
|
(default-test-converter form)))) |
238 |
|
|
239 |
|
(defun memf-code-converter (form generic-function |
240 |
|
metatypes applyp method-alist-p wrappers-p) |
241 |
|
(cond ((and (consp form) (eq (car form) 'call-method)) |
242 |
|
(let ((gensym (get-effective-method-gensym))) |
243 |
|
(values (make-emf-call metatypes applyp gensym |
244 |
|
(make-effective-method-function-type |
245 |
|
generic-function form method-alist-p wrappers-p)) |
246 |
|
(list gensym)))) |
247 |
|
((and (consp form) (eq (car form) 'call-method-list)) |
248 |
|
(let ((gensym (get-effective-method-gensym)) |
249 |
|
(type (if (every #'(lambda (form) |
250 |
|
(eq 'fast-method-call |
251 |
|
(make-effective-method-function-type |
252 |
|
generic-function form |
253 |
|
method-alist-p wrappers-p))) |
254 |
|
(cdr form)) |
255 |
|
'fast-method-call |
256 |
|
't))) |
257 |
|
(values `(dolist (emf ,gensym nil) |
258 |
|
,(make-emf-call metatypes applyp 'emf type)) |
259 |
|
(list gensym)))) |
260 |
|
(t |
261 |
|
(default-code-converter form)))) |
262 |
|
|
263 |
|
(defun memf-constant-converter (form generic-function) |
264 |
|
(cond ((and (consp form) (eq (car form) 'call-method)) |
265 |
|
(list (cons '.meth. |
266 |
|
(make-effective-method-function-simple |
267 |
|
generic-function form)))) |
268 |
|
((and (consp form) (eq (car form) 'call-method-list)) |
269 |
|
(list (cons '.meth-list. |
270 |
|
(mapcar #'(lambda (form) |
271 |
|
(make-effective-method-function-simple |
272 |
|
generic-function form)) |
273 |
|
(cdr form))))) |
274 |
|
(t |
275 |
|
(default-constant-converter form)))) |
276 |
|
|
277 |
|
(defun make-effective-method-function-internal (generic-function effective-method |
278 |
|
method-alist-p wrappers-p) |
279 |
|
(multiple-value-bind (nreq applyp metatypes nkeys arg-info) |
280 |
|
(get-generic-function-info generic-function) |
281 |
|
(declare (ignore nkeys arg-info)) |
282 |
|
(let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) |
283 |
|
(name (if (early-gf-p generic-function) |
284 |
|
(early-gf-name generic-function) |
285 |
|
(generic-function-name generic-function))) |
286 |
|
(arg-info (cons nreq applyp)) |
287 |
|
(effective-method-lambda (expand-effective-method-function |
288 |
|
generic-function effective-method))) |
289 |
|
(multiple-value-bind (cfunction constants) |
290 |
|
(get-function1 effective-method-lambda |
291 |
|
#'(lambda (form) |
292 |
|
(memf-test-converter form generic-function |
293 |
|
method-alist-p wrappers-p)) |
294 |
|
#'(lambda (form) |
295 |
|
(memf-code-converter form generic-function |
296 |
|
metatypes applyp |
297 |
|
method-alist-p wrappers-p)) |
298 |
|
#'(lambda (form) |
299 |
|
(memf-constant-converter form generic-function))) |
300 |
|
#'(lambda (method-alist wrappers) |
301 |
|
(let* ((constants |
302 |
|
(mapcar #'(lambda (constant) |
303 |
|
(if (consp constant) |
304 |
|
(case (car constant) |
305 |
|
(.meth. |
306 |
|
(funcall (the function (cdr constant)) |
307 |
|
method-alist wrappers)) |
308 |
|
(.meth-list. |
309 |
|
(mapcar #'(lambda (fn) |
310 |
|
(funcall (the function fn) |
311 |
|
method-alist wrappers)) |
312 |
|
(cdr constant))) |
313 |
|
(t constant)) |
314 |
|
constant)) |
315 |
|
constants)) |
316 |
|
(function (set-function-name |
317 |
|
(apply cfunction constants) |
318 |
|
`(combined-method ,name)))) |
319 |
|
(make-fast-method-call :function function |
320 |
|
:arg-info arg-info))))))) |
321 |
|
|
322 |
|
(defmacro call-method-list (&rest calls) |
323 |
|
`(progn ,@calls)) |
324 |
|
|
325 |
|
(defun make-call-methods (methods) |
326 |
|
`(call-method-list |
327 |
|
,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) |
328 |
|
|
329 |
|
(defun standard-compute-effective-method (generic-function combin applicable-methods) |
330 |
|
(declare (ignore combin)) |
331 |
|
(let ((before ()) |
332 |
|
(primary ()) |
333 |
|
(after ()) |
334 |
|
(around ())) |
335 |
|
(dolist (m applicable-methods) |
336 |
|
(let ((qualifiers (if (listp m) |
337 |
|
(early-method-qualifiers m) |
338 |
|
(method-qualifiers m)))) |
339 |
|
(cond ((member ':before qualifiers) (push m before)) |
340 |
|
((member ':after qualifiers) (push m after)) |
341 |
|
((member ':around qualifiers) (push m around)) |
342 |
|
(t |
343 |
|
(push m primary))))) |
344 |
|
(setq before (reverse before) |
345 |
|
after (reverse after) |
346 |
|
primary (reverse primary) |
347 |
|
around (reverse around)) |
348 |
|
(cond ((null primary) |
349 |
|
`(error "No primary method for the generic function ~S." ',generic-function)) |
350 |
|
((and (null before) (null after) (null around)) |
351 |
|
;; |
352 |
|
;; By returning a single call-method `form' here we enable an important |
353 |
|
;; implementation-specific optimization. |
354 |
|
;; |
355 |
|
`(call-method ,(first primary) ,(rest primary))) |
356 |
|
(t |
357 |
|
(let ((main-effective-method |
358 |
|
(if (or before after) |
359 |
|
`(multiple-value-prog1 |
360 |
|
(progn ,(make-call-methods before) |
361 |
|
(call-method ,(first primary) ,(rest primary))) |
362 |
|
,(make-call-methods (reverse after))) |
363 |
|
`(call-method ,(first primary) ,(rest primary))))) |
364 |
|
(if around |
365 |
|
`(call-method ,(first around) |
366 |
|
(,@(rest around) (make-method ,main-effective-method))) |
367 |
|
main-effective-method)))))) |
368 |
|
|
369 |
|
;;; |
370 |
|
;;; The STANDARD method combination type. This is coded by hand (rather than |
371 |
|
;;; with define-method-combination) for bootstrapping and efficiency reasons. |
372 |
|
;;; Note that the definition of the find-method-combination-method appears in |
373 |
|
;;; the file defcombin.lisp, this is because EQL methods can't appear in the |
374 |
|
;;; bootstrap. |
375 |
|
;;; |
376 |
|
;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION |
377 |
|
;;; classes has to appear here for this reason. This code must conform to |
378 |
|
;;; the code in the file defcombin, look there for more details. |
379 |
|
;;; |
380 |
|
|
381 |
|
(defun compute-effective-method (generic-function combin applicable-methods) |
382 |
|
(standard-compute-effective-method generic-function combin applicable-methods)) |
383 |
|
|
384 |
|
(defvar *invalid-method-error* |
385 |
|
#'(lambda (&rest args) |
386 |
|
(declare (ignore args)) |
387 |
|
(error |
388 |
|
"INVALID-METHOD-ERROR was called outside the dynamic scope~%~ |
389 |
|
of a method combination function (inside the body of~%~ |
390 |
|
DEFINE-METHOD-COMBINATION or a method on the generic~%~ |
391 |
|
function COMPUTE-EFFECTIVE-METHOD)."))) |
392 |
|
|
393 |
|
(defvar *method-combination-error* |
394 |
|
#'(lambda (&rest args) |
395 |
|
(declare (ignore args)) |
396 |
|
(error |
397 |
|
"METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ |
398 |
|
of a method combination function (inside the body of~%~ |
399 |
|
DEFINE-METHOD-COMBINATION or a method on the generic~%~ |
400 |
|
function COMPUTE-EFFECTIVE-METHOD)."))) |
401 |
|
|
402 |
|
;(defmethod compute-effective-method :around ;issue with magic |
403 |
|
; ((generic-function generic-function) ;generic functions |
404 |
|
; (method-combination method-combination) |
405 |
|
; applicable-methods) |
406 |
|
; (declare (ignore applicable-methods)) |
407 |
|
; (flet ((real-invalid-method-error (method format-string &rest args) |
408 |
|
; (declare (ignore method)) |
409 |
|
; (apply #'error format-string args)) |
410 |
|
; (real-method-combination-error (format-string &rest args) |
411 |
|
; (apply #'error format-string args))) |
412 |
|
; (let ((*invalid-method-error* #'real-invalid-method-error) |
413 |
|
; (*method-combination-error* #'real-method-combination-error)) |
414 |
|
; (call-next-method)))) |
415 |
|
|
416 |
|
(defun invalid-method-error (&rest args) |
417 |
|
(declare (arglist method format-string &rest format-arguments)) |
418 |
|
(apply *invalid-method-error* args)) |
419 |
|
|
420 |
|
(defun method-combination-error (&rest args) |
421 |
|
(declare (arglist format-string &rest format-arguments)) |
422 |
|
(apply *method-combination-error* args)) |
423 |
|
|
424 |
|
;This definition appears in defcombin.lisp. |
425 |
|
; |
426 |
|
;(defmethod find-method-combination ((generic-function generic-function) |
427 |
|
; (type (eql 'standard)) |
428 |
|
; options) |
429 |
|
; (when options |
430 |
|
; (method-combination-error |
431 |
|
; "The method combination type STANDARD accepts no options.")) |
432 |
|
; *standard-method-combination*) |
433 |
|
|