/[gcl]/gcl/pcl/gcl_pcl_combin.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 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    
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26