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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5