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

Diff of /src/pcl/combin.lisp

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

revision 1.4 by ram, Sat Aug 1 15:28:21 1992 UTC revision 1.5 by ram, Mon Nov 9 15:18:26 1992 UTC
# Line 27  Line 27 
27    
28  (in-package 'pcl)  (in-package 'pcl)
29    
 (defun null-wrappers-method-function (&rest args)  
   ;; Function returned when get-method-function passed no wrappers for  
   ;; caching.  I'm not exactly sure why get-method-function gets called  
   ;; with null wrappers when a generic function is first created, but  
   ;; they do.  However, the method-function returned never seemed to  
   ;; get called, so to save a bunch of unneed closure-generation  
   ;; and other muckity-muck, this function is just returned instead.  
   (error "Internal PCL error:  Calling method-function created by  
           get-method-function with wrappers NIL.  Called with args: ~S"  
          args))  
   
30  (defun get-method-function (method &optional method-alist wrappers)  (defun get-method-function (method &optional method-alist wrappers)
31    (or (cadr (assq method method-alist))    (let ((fn (cadr (assoc method method-alist))))
32        (if wrappers      (if fn
33            (method-function-for-caching method wrappers)          (values fn nil nil nil)
34            (or (method-optimized-function method)          (multiple-value-bind (mf fmf)
35                #'null-wrappers-method-function))))              (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  (defun make-effective-method-function (generic-function form &optional
54                                         method-alist wrappers)                                         method-alist wrappers)
55    (funcall-function (make-effective-method-function1 generic-function form)    (funcall (make-effective-method-function1 generic-function form
56                      method-alist wrappers))                                              (not (null method-alist))
57                                                (not (null wrappers)))
58               method-alist wrappers))
59    
60  (defun make-effective-method-function1 (generic-function form)  (defun make-effective-method-function1 (generic-function form
61                                            method-alist-p wrappers-p)
62    (if (and (listp form)    (if (and (listp form)
63             (eq (car form) 'call-method)             (eq (car form) 'call-method))
            (method-p (cadr form))  
            (or (every #'method-p (caddr form))  
                (not (method-needs-next-methods-p (cadr form)))))  
64        (make-effective-method-function-simple generic-function form)        (make-effective-method-function-simple generic-function form)
65        ;;        ;;
66        ;; We have some sort of `real' effective method.  Go off and get a        ;; 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        ;; compiled function for it.  Most of the real hair here is done by
68        ;; the GET-FUNCTION mechanism.        ;; the GET-FUNCTION mechanism.
69        ;;        ;;
70        (make-effective-method-function-internal generic-function form)))        (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)  (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    ;; 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    ;; the possibility of just using the method function of the method as
105    ;; as the effective method function.    ;; the effective method function.
106    ;;    ;;
107    ;; But we have to be careful.  If that method function will ask for    ;; 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    ;; the next methods we have to provide them.  We do not look to see
# Line 76  Line 110 
110    ;; asks about them.  If it does, we must tell it whether there are    ;; asks about them.  If it does, we must tell it whether there are
111    ;; or aren't to prevent the leaky next methods bug.    ;; or aren't to prevent the leaky next methods bug.
112    ;;    ;;
113    (let ((method (cadr form)))    (let* ((cm-args (cdr form))
114      (if (not (method-needs-next-methods-p method))           (fmf-p (and (null no-fmf-p)
115          #'(lambda (method-alist wrappers)                       (or (not (eq *boot-state* 'complete))
116              (get-method-function method method-alist wrappers))                           (gf-fast-method-function-p generic-function))
117          (let* ((arg-info (gf-arg-info generic-function))                       (null (cddr cm-args))))
118                 (metatypes (arg-info-metatypes arg-info))           (method (car cm-args))
119                 (applyp (arg-info-applyp arg-info))           (cm-args1 (cdr cm-args)))
120                 (next-methods (caddr form)))      #'(lambda (method-alist wrappers)
121            (declare (type boolean applyp))          (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
122            (multiple-value-bind (cfunction constants)                                                  method-alist wrappers))))
123                (get-function1  
124                 `(lambda ,(make-dfun-lambda-list metatypes applyp)  (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers)
125                    (let ((*next-methods* .next-methods.))    (multiple-value-bind (mf real-mf-p fmf pv-cell)
126                      ,(make-dfun-call metatypes applyp '.method.)))        (get-method-function method method-alist wrappers)
127                 #'default-test-converter ;This could be optimized by making      (if fmf
128                                          ;the interface from here to the          (let* ((next-methods (car cm-args))
129                                          ;walker more clear so that the                 (next (make-effective-method-function-simple1
130                                          ;form wouldn't get walked at all.                        gf (car next-methods)
131                 #'(lambda (form)                        (list* (cdr next-methods) (cdr cm-args))
132                     (if (memq form '(.next-methods. .method.))                        fmf-p method-alist wrappers))
133                         (values form (list form))                 (arg-info (method-function-get fmf ':arg-info)))
134                         form))            (make-fast-method-call :function fmf
135                 #'(lambda (form)                                   :pv-cell pv-cell
136                     (cond ((eq form '.next-methods.)                                   :next-method-call next
137                            (list (cons '.meth-list. next-methods)))                                   :arg-info arg-info))
138                           ((eq form '.method.)          (if real-mf-p
139                            (list (cons '.meth. method))))))              (make-method-call :function mf
140              #'(lambda (method-alist wrappers)                                :call-method-args cm-args)
141                  (flet ((fix-meth (meth)              mf))))
142                           (get-method-function meth method-alist wrappers)))  
143                    (apply-function cfunction  (defun make-effective-method-function-simple1 (gf method cm-args fmf-p
144                                    (mapcar #'(lambda (constant)                                                    &optional method-alist wrappers)
145                                                (cond ((atom constant)    (when method
146                                                       constant)      (if (if (listp method)
147                                                      ((eq (car constant) '.meth.)              (eq (car method) ':early-method)
148                                                       (fix-meth (cdr constant)))              (method-p method))
149                                                      ((eq (car constant) '.meth-list.)          (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
150                                                       (mapcar #'fix-meth (cdr constant)))          (if (and (consp method) (eq (car method) 'make-method))
151                                                      (t constant)))              (make-effective-method-function gf (cadr method) method-alist wrappers)
152                                            constants)))))))))              method))))
153    
 (declaim (type list *global-effective-method-gensyms*))  
154  (defvar *global-effective-method-gensyms* ())  (defvar *global-effective-method-gensyms* ())
155  (defvar *rebound-effective-method-gensyms*)  (defvar *rebound-effective-method-gensyms*)
156    
# Line 133  Line 166 
166  (let ((*rebound-effective-method-gensyms* ()))  (let ((*rebound-effective-method-gensyms* ()))
167    (dotimes (i 10) (get-effective-method-gensym)))    (dotimes (i 10) (get-effective-method-gensym)))
168    
169  (defun make-effective-method-function-internal (generic-function effective-method)  (defun expand-effective-method-function (gf effective-method &optional env)
170    (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)    (declare (ignore env))
171           (arg-info (gf-arg-info generic-function))    (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
172           (metatypes (arg-info-metatypes arg-info))        (get-generic-function-info gf)
173           (applyp (arg-info-applyp arg-info)))      (declare (ignore nreq nkeys arg-info))
174      (declare (type boolean applyp))      `(lambda ,(make-fast-method-call-lambda-list metatypes applyp)
175      (labels ((test-converter (form)         (declare (ignore .pv-cell. .next-method-call.))
176                 (if (and (consp form) (eq (car form) 'call-method))         ,effective-method)))
177                     (if (caddr form)  
178                         '.call-method-with-next.  (defun expand-emf-call-method (gf form metatypes applyp env)
179                         '.call-method-without-next.)    (declare (ignore gf metatypes applyp env))
180                     (default-test-converter form)))    `(call-method ,(cdr form)))
181               (code-converter (form)  
182                 (if (and (consp form) (eq (car form) 'call-method))  (defmacro call-method (&rest args)
183                     ;;    (declare (ignore args))
184                     ;; We have a `call' to CALL-METHOD.  There may or may not be next    `(error "~S outsize of a effective method form" 'call-method))
185                     ;; methods and the two cases are a little different.  It controls  
186                     ;; how many gensyms we will generate.  (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
187                     ;;    (cond ((and (consp form) (eq (car form) 'call-method))
188                     (let ((gensyms           (case (make-effective-method-function-type
189                            (if (caddr form)                  generic-function form method-alist-p wrappers-p)
190                                (list (get-effective-method-gensym)             (fast-method-call
191                                      (get-effective-method-gensym))              '.fast-call-method.)
192                                (list (get-effective-method-gensym)))))             (t
193                       (values `(let ((*next-methods* ,(cadr gensyms)))              '.call-method.)))
194                                 ,(make-dfun-call metatypes applyp (car gensyms)))          ((and (consp form) (eq (car form) 'call-method-list))
195                               gensyms))           (case (if (every #'(lambda (form)
196                     (default-code-converter form)))                                (eq 'fast-method-call
197               (constant-converter (form)                                    (make-effective-method-function-type
198                 (if (and (consp form) (eq (car form) 'call-method))                                     generic-function form
199                     (if (caddr form)                                     method-alist-p wrappers-p)))
200                         (list (cons '.meth. (check-for-make-method (cadr form)))                            (cdr form))
201                               (cons '.meth-list.                     'fast-method-call
202                                     (mapcar #'check-for-make-method (caddr form))))                     't)
203                         (list (cons '.meth. (check-for-make-method (cadr form)))))             (fast-method-call
204                     (default-constant-converter form)))              '.fast-call-method-list.)
205               (check-for-make-method (effective-method)             (t
206                 (cond ((method-p effective-method)              '.call-method-list.)))
207                        effective-method)          (t
208                       ((and (listp effective-method)           (default-test-converter form))))
209                             (eq (car effective-method) 'make-method))  
210                        (make-effective-method-function1  (defun memf-code-converter (form generic-function
211                         generic-function                                   metatypes applyp method-alist-p wrappers-p)
212                         (make-progn (cadr effective-method))))    (cond ((and (consp form) (eq (car form) 'call-method))
213                       (t           (let ((gensym (get-effective-method-gensym)))
214                        (error "Effective-method form is malformed.")))))             (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)        (multiple-value-bind (cfunction constants)
261            (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp)            (get-function1 effective-method-lambda
262                             ,effective-method)                           #'(lambda (form)
263                           #'test-converter                               (memf-test-converter form generic-function
264                           #'code-converter                                                    method-alist-p wrappers-p))
265                           #'constant-converter)                           #'(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)          #'(lambda (method-alist wrappers)
272              (flet ((fix-meth (meth)              (let* ((constants
273                       (if (method-p meth)                      (mapcar #'(lambda (constant)
274                           (get-method-function meth method-alist wrappers)                                  (if (consp constant)
275                           (funcall-function meth method-alist wrappers))))                                      (case (car constant)
276                (apply-function cfunction                                        (.meth.
277                                (mapcar #'(lambda (constant)                                         (funcall (cdr constant)
278                                            (cond ((atom constant)                                                  method-alist wrappers))
279                                                   constant)                                        (.meth-list.
280                                                  ((eq (car constant) '.meth.)                                         (mapcar #'(lambda (fn)
281                                                   (fix-meth (cdr constant)))                                                     (funcall fn method-alist wrappers))
282                                                  ((eq (car constant) '.meth-list.)                                                 (cdr constant)))
283                                                   (mapcar #'fix-meth (cdr constant)))                                        (t constant))
284                                                  (t constant)))                                      constant))
285                                        constants))))))))                              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*  (defvar *invalid-method-error*
355          #'(lambda (&rest args)          #'(lambda (&rest args)
# Line 243  Line 391 
391    (declare (arglist format-string &rest format-arguments))    (declare (arglist format-string &rest format-arguments))
392    (apply *method-combination-error* args))    (apply *method-combination-error* args))
393    
   
   
 ;;;  
 ;;; The STANDARD method combination type.  This is coded by hand (rather than  
 ;;; with define-method-combination) for bootstrapping and efficiency reasons.  
 ;;; Note that the definition of the find-method-combination-method appears in  
 ;;; the file defcombin.lisp, this is because EQL methods can't appear in the  
 ;;; bootstrap.  
 ;;;  
 ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION  
 ;;; classes has to appear here for this reason.  This code must conform to  
 ;;; the code in the file defcombin, look there for more details.  
 ;;;  
   
 (defclass method-combination (metaobject) ()  
   (:predicate-name method-combination-p))  
   
   
 (mapc  
  #'proclaim-incompatible-superclasses  
  '(;; superclass metaobject  
    (class eql-specializer class-eq-specializer method method-combination  
     generic-function slot-definition)  
    ))  
   
 (defclass standard-method-combination  
           (documentation-mixin definition-source-mixin method-combination)  
      ((type          :reader method-combination-type  
                      :initarg :type)  
       (options       :reader method-combination-options  
                      :initarg :options)))  
   
 (defmethod print-object ((mc method-combination) stream)  
   (printing-random-thing (mc stream)  
     (format stream  
             "Method-Combination ~S ~S"  
             (method-combination-type mc)  
             (method-combination-options mc))))  
   
 (eval-when (load eval)  
   (setq *standard-method-combination*  
         (make-instance 'standard-method-combination  
                        :type 'standard  
                        :documentation "The standard method combination."  
                        :options ())))  
   
394  ;This definition appears in defcombin.lisp.  ;This definition appears in defcombin.lisp.
395  ;  ;
396  ;(defmethod find-method-combination ((generic-function generic-function)  ;(defmethod find-method-combination ((generic-function generic-function)
# Line 299  Line 401 
401  ;      "The method combination type STANDARD accepts no options."))  ;      "The method combination type STANDARD accepts no options."))
402  ;  *standard-method-combination*)  ;  *standard-method-combination*)
403    
 (defun make-call-methods (methods)  
   (mapcar #'(lambda (method) `(call-method ,method ())) methods))  
   
 (defmethod compute-effective-method ((generic-function generic-function)  
                                      (combin standard-method-combination)  
                                      applicable-methods)  
   (let ((before ())  
         (primary ())  
         (after ())  
         (around ()))  
     (dolist (m applicable-methods)  
       (let ((qualifiers (method-qualifiers m)))  
         (cond ((memq ':before qualifiers)  (push m before))  
               ((memq ':after  qualifiers)  (push m after))  
               ((memq ':around  qualifiers) (push m around))  
               (t  
                (push m primary)))))  
     (setq before  (reverse before)  
           after   (reverse after)  
           primary (reverse primary)  
           around  (reverse around))  
     (cond ((null primary)  
            `(error "No primary method for the generic function ~S." ',generic-function))  
           ((and (null before) (null after) (null around))  
            ;;  
            ;; By returning a single call-method `form' here we enable an important  
            ;; implementation-specific optimization.  
            ;;  
            `(call-method ,(first primary) ,(rest primary)))  
           (t  
            (let ((main-effective-method  
                    (if (or before after)  
                        `(multiple-value-prog1  
                           (progn ,@(make-call-methods before)  
                                  (call-method ,(first primary) ,(rest primary)))  
                           ,@(make-call-methods (reverse after)))  
                        `(call-method ,(first primary) ,(rest primary)))))  
              (if around  
                  `(call-method ,(first around)  
                                (,@(rest around) (make-method ,main-effective-method)))  
                  main-effective-method))))))  
   

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5