/[cmucl]/src/pcl/combin.lisp
ViewVC logotype

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Tue Jan 12 18:23:29 1993 UTC (21 years, 3 months ago) by phg
Branch: MAIN
CVS Tags: RELEASE_18a
Branch point for: RELENG_18
Changes since 1.5: +1 -1 lines
September-16-92-PCL-e has been incorporated into the CMUCL sources thanks
to Rick Harris.
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 (make-effective-method-function1 generic-function form
56 (not (null method-alist))
57 (not (null wrappers)))
58 method-alist wrappers))
59
60 (defun make-effective-method-function1 (generic-function form
61 method-alist-p wrappers-p)
62 (if (and (listp form)
63 (eq (car form) 'call-method))
64 (make-effective-method-function-simple generic-function form)
65 ;;
66 ;; We have some sort of `real' effective method. Go off and get a
67 ;; compiled function for it. Most of the real hair here is done by
68 ;; the GET-FUNCTION mechanism.
69 ;;
70 (make-effective-method-function-internal generic-function form
71 method-alist-p wrappers-p)))
72
73 (defun make-effective-method-function-type (generic-function form
74 method-alist-p wrappers-p)
75 (if (and (listp form)
76 (eq (car form) 'call-method))
77 (let* ((cm-args (cdr form))
78 (method (car cm-args)))
79 (when method
80 (if (if (listp method)
81 (eq (car method) ':early-method)
82 (method-p method))
83 (if method-alist-p
84 't
85 (multiple-value-bind (mf fmf)
86 (if (listp method)
87 (early-method-function method)
88 (values nil (method-fast-function method)))
89 (declare (ignore mf))
90 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
91 (if (and fmf (or (null pv-table) wrappers-p))
92 'fast-method-call
93 'method-call))))
94 (if (and (consp method) (eq (car method) 'make-method))
95 (make-effective-method-function-type
96 generic-function (cadr method) method-alist-p wrappers-p)
97 (type-of method)))))
98 'fast-method-call))
99
100 (defun make-effective-method-function-simple (generic-function form
101 &optional no-fmf-p)
102 ;;
103 ;; The effective method is just a call to call-method. This opens up
104 ;; the possibility of just using the method function of the method as
105 ;; the effective method function.
106 ;;
107 ;; But we have to be careful. If that method function will ask for
108 ;; the next methods we have to provide them. We do not look to see
109 ;; if there are next methods, we look at whether the method function
110 ;; asks about them. If it does, we must tell it whether there are
111 ;; or aren't to prevent the leaky next methods bug.
112 ;;
113 (let* ((cm-args (cdr form))
114 (fmf-p (and (null no-fmf-p)
115 (or (not (eq *boot-state* 'complete))
116 (gf-fast-method-function-p generic-function))
117 (null (cddr cm-args))))
118 (method (car cm-args))
119 (cm-args1 (cdr cm-args)))
120 #'(lambda (method-alist wrappers)
121 (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
122 method-alist wrappers))))
123
124 (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers)
125 (multiple-value-bind (mf real-mf-p fmf pv-cell)
126 (get-method-function method method-alist wrappers)
127 (if fmf
128 (let* ((next-methods (car cm-args))
129 (next (make-effective-method-function-simple1
130 gf (car next-methods)
131 (list* (cdr next-methods) (cdr cm-args))
132 fmf-p method-alist wrappers))
133 (arg-info (method-function-get fmf ':arg-info)))
134 (make-fast-method-call :function fmf
135 :pv-cell pv-cell
136 :next-method-call next
137 :arg-info arg-info))
138 (if real-mf-p
139 (make-method-call :function mf
140 :call-method-args cm-args)
141 mf))))
142
143 (defun make-effective-method-function-simple1 (gf method cm-args fmf-p
144 &optional method-alist wrappers)
145 (when method
146 (if (if (listp method)
147 (eq (car method) ':early-method)
148 (method-p method))
149 (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
150 (if (and (consp method) (eq (car method) 'make-method))
151 (make-effective-method-function gf (cadr method) method-alist wrappers)
152 method))))
153
154 (defvar *global-effective-method-gensyms* ())
155 (defvar *rebound-effective-method-gensyms*)
156
157 (defun get-effective-method-gensym ()
158 (or (pop *rebound-effective-method-gensyms*)
159 (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D"
160 (length *global-effective-method-gensyms*))
161 "PCL")))
162 (setq *global-effective-method-gensyms*
163 (append *global-effective-method-gensyms* (list new)))
164 new)))
165
166 (let ((*rebound-effective-method-gensyms* ()))
167 (dotimes (i 10) (get-effective-method-gensym)))
168
169 (defun expand-effective-method-function (gf effective-method &optional env)
170 (declare (ignore env))
171 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
172 (get-generic-function-info gf)
173 (declare (ignore nreq nkeys arg-info))
174 `(lambda ,(make-fast-method-call-lambda-list metatypes applyp)
175 (declare (ignore .pv-cell. .next-method-call.))
176 ,effective-method)))
177
178 (defun expand-emf-call-method (gf form metatypes applyp env)
179 (declare (ignore gf metatypes applyp env))
180 `(call-method ,(cdr form)))
181
182 (defmacro call-method (&rest args)
183 (declare (ignore args))
184 `(error "~S outsize of a effective method form" 'call-method))
185
186 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
187 (cond ((and (consp form) (eq (car form) 'call-method))
188 (case (make-effective-method-function-type
189 generic-function form method-alist-p wrappers-p)
190 (fast-method-call
191 '.fast-call-method.)
192 (t
193 '.call-method.)))
194 ((and (consp form) (eq (car form) 'call-method-list))
195 (case (if (every #'(lambda (form)
196 (eq 'fast-method-call
197 (make-effective-method-function-type
198 generic-function form
199 method-alist-p wrappers-p)))
200 (cdr form))
201 'fast-method-call
202 't)
203 (fast-method-call
204 '.fast-call-method-list.)
205 (t
206 '.call-method-list.)))
207 (t
208 (default-test-converter form))))
209
210 (defun memf-code-converter (form generic-function
211 metatypes applyp method-alist-p wrappers-p)
212 (cond ((and (consp form) (eq (car form) 'call-method))
213 (let ((gensym (get-effective-method-gensym)))
214 (values (make-emf-call metatypes applyp gensym
215 (make-effective-method-function-type
216 generic-function form method-alist-p wrappers-p))
217 (list gensym))))
218 ((and (consp form) (eq (car form) 'call-method-list))
219 (let ((gensym (get-effective-method-gensym))
220 (type (if (every #'(lambda (form)
221 (eq 'fast-method-call
222 (make-effective-method-function-type
223 generic-function form
224 method-alist-p wrappers-p)))
225 (cdr form))
226 'fast-method-call
227 't)))
228 (values `(dolist (emf ,gensym nil)
229 ,(make-emf-call metatypes applyp 'emf type))
230 (list gensym))))
231 (t
232 (default-code-converter form))))
233
234 (defun memf-constant-converter (form generic-function)
235 (cond ((and (consp form) (eq (car form) 'call-method))
236 (list (cons '.meth.
237 (make-effective-method-function-simple
238 generic-function form))))
239 ((and (consp form) (eq (car form) 'call-method-list))
240 (list (cons '.meth-list.
241 (mapcar #'(lambda (form)
242 (make-effective-method-function-simple
243 generic-function form))
244 (cdr form)))))
245 (t
246 (default-constant-converter form))))
247
248 (defun make-effective-method-function-internal (generic-function effective-method
249 method-alist-p wrappers-p)
250 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
251 (get-generic-function-info generic-function)
252 (declare (ignore nkeys arg-info))
253 (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
254 (name (if (early-gf-p generic-function)
255 (early-gf-name generic-function)
256 (generic-function-name generic-function)))
257 (arg-info (cons nreq applyp))
258 (effective-method-lambda (expand-effective-method-function
259 generic-function effective-method)))
260 (multiple-value-bind (cfunction constants)
261 (get-function1 effective-method-lambda
262 #'(lambda (form)
263 (memf-test-converter form generic-function
264 method-alist-p wrappers-p))
265 #'(lambda (form)
266 (memf-code-converter form generic-function
267 metatypes applyp
268 method-alist-p wrappers-p))
269 #'(lambda (form)
270 (memf-constant-converter form generic-function)))
271 #'(lambda (method-alist wrappers)
272 (let* ((constants
273 (mapcar #'(lambda (constant)
274 (if (consp constant)
275 (case (car constant)
276 (.meth.
277 (funcall (cdr constant)
278 method-alist wrappers))
279 (.meth-list.
280 (mapcar #'(lambda (fn)
281 (funcall fn method-alist wrappers))
282 (cdr constant)))
283 (t constant))
284 constant))
285 constants))
286 (function (set-function-name
287 (apply cfunction constants)
288 `(combined-method ,name))))
289 (make-fast-method-call :function function
290 :arg-info arg-info)))))))
291
292 (defmacro call-method-list (&rest calls)
293 `(progn ,@calls))
294
295 (defun make-call-methods (methods)
296 `(call-method-list
297 ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
298
299 (defun standard-compute-effective-method (generic-function combin applicable-methods)
300 (declare (ignore combin))
301 (let ((before ())
302 (primary ())
303 (after ())
304 (around ()))
305 (dolist (m applicable-methods)
306 (let ((qualifiers (if (listp m)
307 (early-method-qualifiers m)
308 (method-qualifiers m))))
309 (cond ((member ':before qualifiers) (push m before))
310 ((member ':after qualifiers) (push m after))
311 ((member ':around qualifiers) (push m around))
312 (t
313 (push m primary)))))
314 (setq before (reverse before)
315 after (reverse after)
316 primary (reverse primary)
317 around (reverse around))
318 (cond ((null primary)
319 `(error "No primary method for the generic function ~S." ',generic-function))
320 ((and (null before) (null after) (null around))
321 ;;
322 ;; By returning a single call-method `form' here we enable an important
323 ;; implementation-specific optimization.
324 ;;
325 `(call-method ,(first primary) ,(rest primary)))
326 (t
327 (let ((main-effective-method
328 (if (or before after)
329 `(multiple-value-prog1
330 (progn ,(make-call-methods before)
331 (call-method ,(first primary) ,(rest primary)))
332 ,(make-call-methods (reverse after)))
333 `(call-method ,(first primary) ,(rest primary)))))
334 (if around
335 `(call-method ,(first around)
336 (,@(rest around) (make-method ,main-effective-method)))
337 main-effective-method))))))
338
339 ;;;
340 ;;; The STANDARD method combination type. This is coded by hand (rather than
341 ;;; with define-method-combination) for bootstrapping and efficiency reasons.
342 ;;; Note that the definition of the find-method-combination-method appears in
343 ;;; the file defcombin.lisp, this is because EQL methods can't appear in the
344 ;;; bootstrap.
345 ;;;
346 ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
347 ;;; classes has to appear here for this reason. This code must conform to
348 ;;; the code in the file defcombin, look there for more details.
349 ;;;
350
351 (defun compute-effective-method (generic-function combin applicable-methods)
352 (standard-compute-effective-method generic-function combin applicable-methods))
353
354 (defvar *invalid-method-error*
355 #'(lambda (&rest args)
356 (declare (ignore args))
357 (error
358 "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
359 of a method combination function (inside the body of~%~
360 DEFINE-METHOD-COMBINATION or a method on the generic~%~
361 function COMPUTE-EFFECTIVE-METHOD).")))
362
363 (defvar *method-combination-error*
364 #'(lambda (&rest args)
365 (declare (ignore args))
366 (error
367 "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
368 of a method combination function (inside the body of~%~
369 DEFINE-METHOD-COMBINATION or a method on the generic~%~
370 function COMPUTE-EFFECTIVE-METHOD).")))
371
372 ;(defmethod compute-effective-method :around ;issue with magic
373 ; ((generic-function generic-function) ;generic functions
374 ; (method-combination method-combination)
375 ; applicable-methods)
376 ; (declare (ignore applicable-methods))
377 ; (flet ((real-invalid-method-error (method format-string &rest args)
378 ; (declare (ignore method))
379 ; (apply #'error format-string args))
380 ; (real-method-combination-error (format-string &rest args)
381 ; (apply #'error format-string args)))
382 ; (let ((*invalid-method-error* #'real-invalid-method-error)
383 ; (*method-combination-error* #'real-method-combination-error))
384 ; (call-next-method))))
385
386 (defun invalid-method-error (&rest args)
387 (declare (arglist method format-string &rest format-arguments))
388 (apply *invalid-method-error* args))
389
390 (defun method-combination-error (&rest args)
391 (declare (arglist format-string &rest format-arguments))
392 (apply *method-combination-error* args))
393
394 ;This definition appears in defcombin.lisp.
395 ;
396 ;(defmethod find-method-combination ((generic-function generic-function)
397 ; (type (eql 'standard))
398 ; options)
399 ; (when options
400 ; (method-combination-error
401 ; "The method combination type STANDARD accepts no options."))
402 ; *standard-method-combination*)
403

  ViewVC Help
Powered by ViewVC 1.1.5