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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Thu Jan 22 12:32:52 1998 UTC (16 years, 3 months ago) by pw
Branch: MAIN
Changes since 1.6: +8 -3 lines
While loading an :around method when no primary method exists, a compiler
warning like ".ARG0. is defined but not used" was being emitted. Turns
out that in such a case PCL generates an effective-method consisting
of (error "No primary method for ...") or some such, thus ignoring
the user method and not passing the supplied arguments to error. This
change checks for the above case and inserts an ignorable declaration
for the method arguments.
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 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
175 ;; When there are no primary methods and a next-method call occurs
176 ;; effective-method is (error "No mumble..") and the defined
177 ;; args are not used giving a compiler warning.
178 (error-p (eq (first effective-method) 'error)))
179 `(lambda ,ll
180 (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
181 ,effective-method))))
182
183 (defun expand-emf-call-method (gf form metatypes applyp env)
184 (declare (ignore gf metatypes applyp env))
185 `(call-method ,(cdr form)))
186
187 (defmacro call-method (&rest args)
188 (declare (ignore args))
189 `(error "~S outsize of a effective method form" 'call-method))
190
191 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
192 (cond ((and (consp form) (eq (car form) 'call-method))
193 (case (make-effective-method-function-type
194 generic-function form method-alist-p wrappers-p)
195 (fast-method-call
196 '.fast-call-method.)
197 (t
198 '.call-method.)))
199 ((and (consp form) (eq (car form) 'call-method-list))
200 (case (if (every #'(lambda (form)
201 (eq 'fast-method-call
202 (make-effective-method-function-type
203 generic-function form
204 method-alist-p wrappers-p)))
205 (cdr form))
206 'fast-method-call
207 't)
208 (fast-method-call
209 '.fast-call-method-list.)
210 (t
211 '.call-method-list.)))
212 (t
213 (default-test-converter form))))
214
215 (defun memf-code-converter (form generic-function
216 metatypes applyp method-alist-p wrappers-p)
217 (cond ((and (consp form) (eq (car form) 'call-method))
218 (let ((gensym (get-effective-method-gensym)))
219 (values (make-emf-call metatypes applyp gensym
220 (make-effective-method-function-type
221 generic-function form method-alist-p wrappers-p))
222 (list gensym))))
223 ((and (consp form) (eq (car form) 'call-method-list))
224 (let ((gensym (get-effective-method-gensym))
225 (type (if (every #'(lambda (form)
226 (eq 'fast-method-call
227 (make-effective-method-function-type
228 generic-function form
229 method-alist-p wrappers-p)))
230 (cdr form))
231 'fast-method-call
232 't)))
233 (values `(dolist (emf ,gensym nil)
234 ,(make-emf-call metatypes applyp 'emf type))
235 (list gensym))))
236 (t
237 (default-code-converter form))))
238
239 (defun memf-constant-converter (form generic-function)
240 (cond ((and (consp form) (eq (car form) 'call-method))
241 (list (cons '.meth.
242 (make-effective-method-function-simple
243 generic-function form))))
244 ((and (consp form) (eq (car form) 'call-method-list))
245 (list (cons '.meth-list.
246 (mapcar #'(lambda (form)
247 (make-effective-method-function-simple
248 generic-function form))
249 (cdr form)))))
250 (t
251 (default-constant-converter form))))
252
253 (defun make-effective-method-function-internal (generic-function effective-method
254 method-alist-p wrappers-p)
255 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
256 (get-generic-function-info generic-function)
257 (declare (ignore nkeys arg-info))
258 (let* ((*rebound-effective-method-gensyms* *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
267 #'(lambda (form)
268 (memf-test-converter form generic-function
269 method-alist-p wrappers-p))
270 #'(lambda (form)
271 (memf-code-converter form generic-function
272 metatypes applyp
273 method-alist-p wrappers-p))
274 #'(lambda (form)
275 (memf-constant-converter form generic-function)))
276 #'(lambda (method-alist wrappers)
277 (let* ((constants
278 (mapcar #'(lambda (constant)
279 (if (consp constant)
280 (case (car constant)
281 (.meth.
282 (funcall (cdr constant)
283 method-alist wrappers))
284 (.meth-list.
285 (mapcar #'(lambda (fn)
286 (funcall fn method-alist wrappers))
287 (cdr constant)))
288 (t constant))
289 constant))
290 constants))
291 (function (set-function-name
292 (apply cfunction constants)
293 `(combined-method ,name))))
294 (make-fast-method-call :function function
295 :arg-info arg-info)))))))
296
297 (defmacro call-method-list (&rest calls)
298 `(progn ,@calls))
299
300 (defun make-call-methods (methods)
301 `(call-method-list
302 ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
303
304 (defun standard-compute-effective-method (generic-function combin applicable-methods)
305 (declare (ignore combin))
306 (let ((before ())
307 (primary ())
308 (after ())
309 (around ()))
310 (dolist (m applicable-methods)
311 (let ((qualifiers (if (listp m)
312 (early-method-qualifiers m)
313 (method-qualifiers m))))
314 (cond ((member ':before qualifiers) (push m before))
315 ((member ':after qualifiers) (push m after))
316 ((member ':around qualifiers) (push m around))
317 (t
318 (push m primary)))))
319 (setq before (reverse before)
320 after (reverse after)
321 primary (reverse primary)
322 around (reverse around))
323 (cond ((null primary)
324 `(error "No primary method for the generic function ~S." ',generic-function))
325 ((and (null before) (null after) (null around))
326 ;;
327 ;; By returning a single call-method `form' here we enable an important
328 ;; implementation-specific optimization.
329 ;;
330 `(call-method ,(first primary) ,(rest primary)))
331 (t
332 (let ((main-effective-method
333 (if (or before after)
334 `(multiple-value-prog1
335 (progn ,(make-call-methods before)
336 (call-method ,(first primary) ,(rest primary)))
337 ,(make-call-methods (reverse after)))
338 `(call-method ,(first primary) ,(rest primary)))))
339 (if around
340 `(call-method ,(first around)
341 (,@(rest around) (make-method ,main-effective-method)))
342 main-effective-method))))))
343
344 ;;;
345 ;;; The STANDARD method combination type. This is coded by hand (rather than
346 ;;; with define-method-combination) for bootstrapping and efficiency reasons.
347 ;;; Note that the definition of the find-method-combination-method appears in
348 ;;; the file defcombin.lisp, this is because EQL methods can't appear in the
349 ;;; bootstrap.
350 ;;;
351 ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
352 ;;; classes has to appear here for this reason. This code must conform to
353 ;;; the code in the file defcombin, look there for more details.
354 ;;;
355
356 (defun compute-effective-method (generic-function combin applicable-methods)
357 (standard-compute-effective-method generic-function combin applicable-methods))
358
359 (defvar *invalid-method-error*
360 #'(lambda (&rest args)
361 (declare (ignore args))
362 (error
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).")))
367
368 (defvar *method-combination-error*
369 #'(lambda (&rest args)
370 (declare (ignore args))
371 (error
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).")))
376
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))))
390
391 (defun invalid-method-error (&rest args)
392 (declare (arglist method format-string &rest format-arguments))
393 (apply *invalid-method-error* args))
394
395 (defun method-combination-error (&rest args)
396 (declare (arglist format-string &rest format-arguments))
397 (apply *method-combination-error* args))
398
399 ;This definition appears in defcombin.lisp.
400 ;
401 ;(defmethod find-method-combination ((generic-function generic-function)
402 ; (type (eql 'standard))
403 ; options)
404 ; (when options
405 ; (method-combination-error
406 ; "The method combination type STANDARD accepts no options."))
407 ; *standard-method-combination*)
408

  ViewVC Help
Powered by ViewVC 1.1.5