/[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.13 by pmai, Fri Jan 3 18:50:23 2003 UTC revision 1.13.2.1 by gerd, Sun Mar 9 12:47:20 2003 UTC
# Line 23  Line 23 
23  ;;;  ;;;
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
 ;;;  
26    
27  (ext:file-comment  (ext:file-comment
28    "$Header$")    "$Header$")
 ;;;  
   
 (in-package :pcl)  
   
 (defun get-method-function (method &optional method-alist wrappers)  
   (let ((fn (cadr (assoc method method-alist))))  
     (if fn  
         (values fn nil nil nil)  
         (multiple-value-bind (mf fmf)  
             (if (listp method)  
                 (early-method-function method)  
                 (values nil (method-fast-function method)))  
           (let* ((pv-table (and fmf (method-function-pv-table fmf))))  
             (if (and fmf (or (null pv-table) wrappers))  
                 (let* ((pv-wrappers (when pv-table  
                                       (pv-wrappers-from-all-wrappers  
                                        pv-table wrappers)))  
                        (pv-cell (when (and pv-table pv-wrappers)  
                                   (pv-table-lookup pv-table pv-wrappers))))  
                   (values mf t fmf pv-cell))  
                 (values  
                  (or mf (if (listp method)  
                             (setf (cadr method)  
                                   (method-function-from-fast-function fmf))  
                             (method-function method)))  
                  t nil nil)))))))  
   
 (defun make-effective-method-function (generic-function form &optional  
                                        method-alist wrappers)  
   (funcall (make-effective-method-function1 generic-function form  
                                             (not (null method-alist))  
                                             (not (null wrappers)))  
            method-alist wrappers))  
   
 (defun make-effective-method-function1 (generic-function form  
                                         method-alist-p wrappers-p)  
   (if (and (listp form)  
            (eq (car form) 'call-method))  
       (make-effective-method-function-simple generic-function form)  
       ;;  
       ;; We have some sort of `real' effective method.  Go off and get a  
       ;; compiled function for it.  Most of the real hair here is done by  
       ;; the GET-FUNCTION mechanism.  
       ;;  
       (make-effective-method-function-internal generic-function form  
                                                method-alist-p wrappers-p)))  
   
 (defun make-effective-method-function-type (generic-function form  
                                             method-alist-p wrappers-p)  
   (if (and (listp form)  
            (eq (car form) 'call-method))  
       (let* ((cm-args (cdr form))  
              (method (car cm-args)))  
         (when method  
           (if (if (listp method)  
                   (eq (car method) :early-method)  
                   (method-p method))  
               (if method-alist-p  
                   t  
                   (multiple-value-bind (mf fmf)  
                       (if (listp method)  
                           (early-method-function method)  
                           (values nil (method-fast-function method)))  
                     (declare (ignore mf))  
                     (let* ((pv-table (and fmf (method-function-pv-table fmf))))  
                       (if (and fmf (or (null pv-table) wrappers-p))  
                           'fast-method-call  
                           'method-call))))  
               (if (and (consp method) (eq (car method) 'make-method))  
                   (make-effective-method-function-type  
                    generic-function (cadr method) method-alist-p wrappers-p)  
                   (type-of method)))))  
       'fast-method-call))  
   
 (defun make-effective-method-function-simple (generic-function form  
                                                                &optional no-fmf-p)  
   ;;  
   ;; The effective method is just a call to call-method.  This opens up  
   ;; the possibility of just using the method function of the method as  
   ;; the effective method function.  
   ;;  
   ;; But we have to be careful.  If that method function will ask for  
   ;; the next methods we have to provide them.  We do not look to see  
   ;; if there are next methods, we look at whether the method function  
   ;; asks about them.  If it does, we must tell it whether there are  
   ;; or aren't to prevent the leaky next methods bug.  
   ;;  
   (let* ((cm-args (cdr form))  
          (fmf-p (and (null no-fmf-p)  
                      (or (not (eq *boot-state* 'complete))  
                          (gf-fast-method-function-p generic-function))  
                      (null (cddr cm-args))))  
          (method (car cm-args))  
          (cm-args1 (cdr cm-args)))  
     (lambda (method-alist wrappers)  
       (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p  
                                               method-alist wrappers))))  
   
 (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers)  
   (multiple-value-bind (mf real-mf-p fmf pv-cell)  
       (get-method-function method method-alist wrappers)  
     (if fmf  
         (let* ((next-methods (car cm-args))  
                (next (make-effective-method-function-simple1  
                       gf (car next-methods)  
                       (list* (cdr next-methods) (cdr cm-args))  
                       fmf-p method-alist wrappers))  
                (arg-info (method-function-get fmf :arg-info)))  
           (make-fast-method-call :function fmf  
                                  :pv-cell pv-cell  
                                  :next-method-call next  
                                  :arg-info arg-info))  
         (if real-mf-p  
             (make-method-call :function mf  
                               :call-method-args cm-args)  
             mf))))  
   
 (defun make-effective-method-function-simple1 (gf method cm-args fmf-p  
                                                   &optional method-alist wrappers)  
   (when method  
     (if (if (listp method)  
             (eq (car method) :early-method)  
             (method-p method))  
         (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)  
         (if (and (consp method) (eq (car method) 'make-method))  
             (make-effective-method-function gf (cadr method) method-alist wrappers)  
             method))))  
   
 (defvar *global-effective-method-gensyms* ())  
 (defvar *rebound-effective-method-gensyms*)  
   
 (defun get-effective-method-gensym ()  
   (or (pop *rebound-effective-method-gensyms*)  
       (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D"  
                                  (length *global-effective-method-gensyms*))  
                          "PCL")))  
         (setq *global-effective-method-gensyms*  
               (append *global-effective-method-gensyms* (list new)))  
         new)))  
   
 (let ((*rebound-effective-method-gensyms* ()))  
   (dotimes (i 10) (get-effective-method-gensym)))  
   
 (defun expand-effective-method-function (gf effective-method &optional env)  
   (declare (ignore env))  
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)  
       (get-generic-function-info gf)  
     (declare (ignore nreq nkeys arg-info))  
     (let ((ll (make-fast-method-call-lambda-list metatypes applyp)))  
       (cond  
         ;; When there are no primary methods and a next-method call  
         ;; occurs effective-method is (%no-primary-method <gf>),  
         ;; which we define here to collect all gf arguments, to pass  
         ;; those together with the GF to no-primary-method:  
         ((eq (first effective-method) '%no-primary-method)  
          `(lambda (.pv-cell. .next-method-call. &rest .args.)  
             (declare (ignore .pv-cell. .next-method-call.))  
             (flet ((%no-primary-method (gf)  
                      (apply #'no-primary-method gf .args.)))  
               ,effective-method)))  
         ;; When the method combination uses the :arguments option  
         ((and (eq *boot-state* 'complete)  
               ;; Otherwise the METHOD-COMBINATION slot is not bound.  
               (let ((combin (generic-function-method-combination gf)))  
                 (and (long-method-combination-p combin)  
                      (long-method-combination-arguments-lambda-list combin))))  
          (let* ((required (dfun-arg-symbol-list metatypes))  
                 (gf-args (if applyp  
                              `(list* ,@required .dfun-rest-arg.)  
                              `(list ,@required))))  
            `(lambda ,ll  
               (declare (ignore .pv-cell. .next-method-call.))  
               (let ((.gf-args. ,gf-args))  
                 (declare (ignorable .gf-args.))  
                 ,effective-method))))  
         (t  
          `(lambda ,ll  
             (declare (ignore .pv-cell. .next-method-call.))  
             ,effective-method))))))  
   
 (defun expand-emf-call-method (gf form metatypes applyp env)  
   (declare (ignore gf metatypes applyp env))  
   `(call-method ,(cdr form)))  
   
 (defmacro call-method (&rest args)  
   (declare (ignore args))  
   `(error "~S outsize of a effective method form" 'call-method))  
29    
30  (defun memf-test-converter (form generic-function method-alist-p wrappers-p)  (in-package "PCL")
   (cond ((and (consp form) (eq (car form) 'call-method))  
          (case (make-effective-method-function-type  
                 generic-function form method-alist-p wrappers-p)  
            (fast-method-call  
             '.fast-call-method.)  
            (t  
             '.call-method.)))  
         ((and (consp form) (eq (car form) 'call-method-list))  
          (case (if (every (lambda (form)  
                             (eq 'fast-method-call  
                                 (make-effective-method-function-type  
                                  generic-function form  
                                  method-alist-p wrappers-p)))  
                           (cdr form))  
                    'fast-method-call  
                    t)  
            (fast-method-call  
             '.fast-call-method-list.)  
            (t  
             '.call-method-list.)))  
         (t  
          (default-test-converter form))))  
   
 (defun memf-code-converter (form generic-function  
                                  metatypes applyp method-alist-p wrappers-p)  
   (cond ((and (consp form) (eq (car form) 'call-method))  
          (let ((gensym (get-effective-method-gensym)))  
            (values (make-emf-call metatypes applyp gensym  
                                   (make-effective-method-function-type  
                                    generic-function form method-alist-p wrappers-p))  
                    (list gensym))))  
         ((and (consp form) (eq (car form) 'call-method-list))  
          (let ((gensym (get-effective-method-gensym))  
                (type (if (every (lambda (form)  
                                   (eq 'fast-method-call  
                                       (make-effective-method-function-type  
                                        generic-function form  
                                        method-alist-p wrappers-p)))  
                                 (cdr form))  
                          'fast-method-call  
                          t)))  
            (values `(dolist (emf ,gensym nil)  
                       ,(make-emf-call metatypes applyp 'emf type))  
                    (list gensym))))  
         (t  
          (default-code-converter form))))  
31    
32  (defun memf-constant-converter (form generic-function)  ;;;
33    (cond ((and (consp form) (eq (car form) 'call-method))  ;;; In the following:
34           (list (cons '.meth.  ;;;
35                       (make-effective-method-function-simple  ;;; Something "callable" is either a function, a FAST-METHOD-CALL or
36                        generic-function form))))  ;;; a METHOD-CALL instance, which can all be "invoked" by PCL.
37          ((and (consp form) (eq (car form) 'call-method-list))  ;;;
38           (list (cons '.meth-list.  ;;; A generator for a "callable" is a function (closure) taking two
39                       (mapcar (lambda (form)  ;;; arguments METHOD-ALIST and WRAPPERS and returning a callable.
40                                 (make-effective-method-function-simple  ;;;
41                                  generic-function form))  
42                               (cdr form)))))  
43          (t  ;;; *********************************************
44           (default-constant-converter form))))  ;;; The STANDARD method combination type  *******
45    ;;; *********************************************
46  (defun make-effective-method-function-internal (generic-function effective-method  ;;;
47                                                  method-alist-p wrappers-p)  ;;; This is coded by hand (rather than with DEFINE-METHOD-COMBINATION)
48    (multiple-value-bind (nreq applyp metatypes nkeys arg-info)  ;;; for bootstrapping and efficiency reasons.  Note that the
49        (get-generic-function-info generic-function)  ;;; definition of the find-method-combination-method appears in the
50      (declare (ignore nkeys arg-info))  ;;; file defcombin.lisp, this is because EQL methods can't appear in
51      (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)  ;;; the bootstrap.
52             (name (if (early-gf-p generic-function)  ;;;
53                       (early-gf-name generic-function)  ;;; This code must conform to the code in the file defcombin, look
54                       (generic-function-name generic-function)))  ;;; there for more details.
55             (arg-info (cons nreq applyp))  ;;;
            (effective-method-lambda (expand-effective-method-function  
                                      generic-function effective-method)))  
       (multiple-value-bind (cfunction constants)  
           (get-function1 effective-method-lambda  
                          (lambda (form)  
                            (memf-test-converter form generic-function  
                                                 method-alist-p wrappers-p))  
                          (lambda (form)  
                            (memf-code-converter form generic-function  
                                                 metatypes applyp  
                                                 method-alist-p wrappers-p))  
                          (lambda (form)  
                            (memf-constant-converter form generic-function)))  
         (lambda (method-alist wrappers)  
           (let* ((constants  
                   (mapcar (lambda (constant)  
                             (if (consp constant)  
                                 (case (car constant)  
                                   (.meth.  
                                    (funcall (cdr constant)  
                                             method-alist wrappers))  
                                   (.meth-list.  
                                    (mapcar (lambda (fn)  
                                              (funcall fn method-alist wrappers))  
                                            (cdr constant)))  
                                   (t constant))  
                                 constant))  
                           constants))  
                  (function (set-function-name  
                             (apply cfunction constants)  
                             `(combined-method ,name))))  
             (make-fast-method-call :function function  
                                    :arg-info arg-info)))))))  
   
 (defmacro call-method-list (&rest calls)  
   `(progn ,@calls))  
56    
57  (defun make-call-methods (methods)  ;;;
58    `(call-method-list  ;;; When adding a method to COMPUTE-EFFECTIVE-METHOD for the standard
59      ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))  ;;; method combination, COMPUTE-EFFECTIVE-METHOD is called for
60    ;;; determining the effective method of COMPUTE-EFFECTIVE-METHOD.
61    ;;; That's a chicken and egg problem.  It's solved in dfun.lisp by
62    ;;; always calling STANDARD-COMPUTE-EFFECTIVE-METHOD for the case of
63    ;;; COMPUTE-EFFECTIVE-METHOD.
64    ;;;
65    ;;; A similar problem occurs with all generic functions used to compute
66    ;;; an effective method.  For example, if a method for METHOD-QUALIFIERS
67    ;;; is performed, the generic function METHOD-QUALIFIERS will be called,
68    ;;; and it's not ready for use.
69    ;;;
70    ;;; That's actually the well-known meta-circularity of PCL.
71    ;;;
72    ;;; Can we use an existing definition in the compiling PCL, if any,
73    ;;; until the effective method is ready?
74    ;;;
75    #+loadable-pcl
76    (defmethod compute-effective-method ((gf generic-function)
77                                         (combin standard-method-combination)
78                                         applicable-methods)
79      (standard-compute-effective-method gf combin applicable-methods))
80    
81    #-loadable-pcl
82    (defun compute-effective-method (gf combin applicable-methods)
83      (standard-compute-effective-method gf combin applicable-methods))
84    
85  (defun standard-compute-effective-method  (defun standard-compute-effective-method (gf combin applicable-methods)
     (generic-function combin applicable-methods)  
86    (declare (ignore combin))    (declare (ignore combin))
87    (let ((before ())    (let ((before ())
88          (primary ())          (primary ())
# Line 338  Line 91 
91      (flet ((lose (method why)      (flet ((lose (method why)
92               (invalid-method-error               (invalid-method-error
93                method                method
94                "The method ~S ~A.~%~                "~@<The method ~S ~A.  ~
95                 Standard method combination requires all methods to have one~%~                 Standard method combination requires all methods to have one ~
96                 of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~                 of the single qualifiers ~s, ~s and ~s or to have no qualifier ~
97                 have no qualifier at all."                 at all.~@:>"
98                method why)))                method why :around :before :after)))
99        (dolist (m applicable-methods)        (dolist (m applicable-methods)
100          (let ((qualifiers (if (listp m)          (let ((qualifiers (if (listp m)
101                                (early-method-qualifiers m)                                (early-method-qualifiers m)
102                                (method-qualifiers m))))                                (method-qualifiers m))))
103            (cond            (cond ((null qualifiers)
104              ((null qualifiers) (push m primary))                   (push m primary))
105              ((cdr qualifiers)                  ((cdr qualifiers)
106               (lose m "has more than one qualifier"))                   (lose m "has more than one qualifier"))
107              ((eq (car qualifiers) :around)                  ((eq (car qualifiers) :around)
108               (push m around))                   (push m around))
109              ((eq (car qualifiers) :before)                  ((eq (car qualifiers) :before)
110               (push m before))                   (push m before))
111              ((eq (car qualifiers) :after)                  ((eq (car qualifiers) :after)
112               (push m after))                   (push m after))
113              (t                  (t
114               (lose m "has an illegal qualifier"))))))                   (lose m "has an illegal qualifier"))))))
115      (setq before  (reverse before)      (setq before  (reverse before)
116            after   (reverse after)            after   (reverse after)
117            primary (reverse primary)            primary (reverse primary)
118            around  (reverse around))            around  (reverse around))
119      (cond ((null primary)      (cond ((null primary)
120             ;;             `(%no-primary-method ',gf .args.))
            ;; This form is recognized by expand-effective-method-function,  
            ;; which provides a definition for %no-primary-method that  
            ;; collects all gf arguments, and passes them together with the  
            ;; generic function to no-primary-method for more informative  
            ;; error reporting.  
            ;;  
            `(%no-primary-method ',generic-function))  
121            ((and (null before) (null after) (null around))            ((and (null before) (null after) (null around))
122             ;;             ;;
123             ;; By returning a single call-method `form' here we enable an             ;; By returning a single CALL-METHOD form here, we enable an
124             ;; important implementation-specific optimization.             ;; important implementation-specific optimization.
            ;;  
125             `(call-method ,(first primary) ,(rest primary)))             `(call-method ,(first primary) ,(rest primary)))
126            (t            (t
127             (let ((main-effective-method             (let ((main-effective-method
# Line 390  Line 135 
135               (if around               (if around
136                   `(call-method ,(first around)                   `(call-method ,(first around)
137                                 (,@(rest around)                                 (,@(rest around)
138                                  (make-method ,main-effective-method)))                                    (make-method ,main-effective-method)))
139                   main-effective-method))))))                   main-effective-method))))))
140    
 ;;;  
 ;;; 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.  
 ;;;  
   
 (defun compute-effective-method (generic-function combin applicable-methods)  
   (standard-compute-effective-method generic-function combin applicable-methods))  
   
141  (defvar *invalid-method-error*  (defvar *invalid-method-error*
142          (lambda (&rest args)          (lambda (&rest args)
143            (declare (ignore args))            (declare (ignore args))
144            (error            (error
145             "INVALID-METHOD-ERROR was called outside the dynamic scope~%~             "~@<~s was called outside the dynamic scope ~
146              of a method combination function (inside the body of~%~              of a method combination function (inside the body of ~
147              DEFINE-METHOD-COMBINATION or a method on the generic~%~              ~s or a method on the generic function ~s).~@:>"
148              function COMPUTE-EFFECTIVE-METHOD).")))             'invalid-method-error 'define-method-combination
149               'compute-effective-method)))
150    
151  (defvar *method-combination-error*  (defvar *method-combination-error*
152          (lambda (&rest args)          (lambda (&rest args)
153            (declare (ignore args))            (declare (ignore args))
154            (error            (error
155             "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~             "~@<~s was called outside the dynamic scope ~
156              of a method combination function (inside the body of~%~              of a method combination function (inside the body of ~
157              DEFINE-METHOD-COMBINATION or a method on the generic~%~              ~s or a method on the generic function ~s).~@:>"
158              function COMPUTE-EFFECTIVE-METHOD).")))             'method-combination-error 'define-method-combination
159               'compute-effective-method)))
 ;This definition appears in defcombin.lisp.  
 ;  
 ;(defmethod compute-effective-method :around        ;issue with magic  
 ;          ((generic-function generic-function)     ;generic functions  
 ;           (method-combination method-combination)  
 ;           applicable-methods)  
 ;  (declare (ignore applicable-methods))  
 ;  (flet ((real-invalid-method-error (method format-string &rest args)  
 ;          (declare (ignore method))  
 ;          (apply #'error format-string args))  
 ;        (real-method-combination-error (format-string &rest args)  
 ;          (apply #'error format-string args)))  
 ;    (let ((*invalid-method-error* #'real-invalid-method-error)  
 ;         (*method-combination-error* #'real-method-combination-error))  
 ;      (call-next-method))))  
160    
161  (defun invalid-method-error (&rest args)  (defun invalid-method-error (&rest args)
   (declare (arglist method format-string &rest format-arguments))  
162    (apply *invalid-method-error* args))    (apply *invalid-method-error* args))
163    
164  (defun method-combination-error (&rest args)  (defun method-combination-error (&rest args)
   (declare (arglist format-string &rest format-arguments))  
165    (apply *method-combination-error* args))    (apply *method-combination-error* args))
166    
167  ;This definition appears in defcombin.lisp.  (defmacro call-method (&rest args)
168  ;    (declare (ignore args))
169  ;(defmethod find-method-combination ((generic-function generic-function)    `(error "~@<~S used outsize of a effective method form.~@:>" 'call-method))
170  ;                                    (type (eql 'standard))  
171  ;                                    options)  (defmacro call-method-list (&rest calls)
172  ;  (when options    `(progn ,@calls))
173  ;    (method-combination-error  
174  ;      "The method combination type STANDARD accepts no options."))  (defun make-call-methods (methods)
175  ;  *standard-method-combination*)    `(call-method-list
176        ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
177    
178    
179    ;;; ****************************************************
180    ;;; Translating effective method bodies to Code  *******
181    ;;; ****************************************************
182    
183    (defun get-callable (gf form method-alist wrappers)
184      (funcall (callable-generator gf form method-alist wrappers)
185               method-alist wrappers))
186    
187    (defun callable-generator (gf form method-alist-p wrappers-p)
188      (if (eq 'call-method (car-safe form))
189          (callable-generator-for-call-method gf form)
190          (callable-generator-for-emf gf form method-alist-p wrappers-p)))
191    
192    ;;;
193    ;;; If the effective method is just a call to CALL-METHOD, this opens
194    ;;; up the possibility of just using the method function of the method
195    ;;; as the effective method function.
196    ;;;
197    ;;; But we have to be careful.  If that method function will ask for
198    ;;; the next methods we have to provide them.  We do not look to see
199    ;;; if there are next methods, we look at whether the method function
200    ;;; asks about them.  If it does, we must tell it whether there are
201    ;;; or aren't to prevent the leaky next methods bug.
202    ;;;
203    (defun callable-generator-for-call-method (gf form)
204      (let* ((cm-args (cdr form))
205             (fmf-p (and (or (not (eq *boot-state* 'complete))
206                             (gf-fast-method-function-p gf))
207                         (null (cddr cm-args))))
208             (method (car cm-args))
209             (cm-args1 (cdr cm-args)))
210        (lambda (method-alist wrappers)
211          (callable-for-call-method gf method cm-args1 fmf-p method-alist
212                                    wrappers))))
213    
214    (defun callable-for-call-method (gf method cm-args fmf-p method-alist wrappers)
215      (cond ((null method)
216             nil)
217            ((if (listp method)
218                 (eq (car method) :early-method)
219                 (method-p method))
220             (get-method-callable method cm-args gf fmf-p method-alist wrappers))
221            ((eq 'make-method (car-safe method))
222             (get-callable gf (cadr method) method-alist wrappers))
223            (t
224             method)))
225    
226    ;;;
227    ;;; Return a FAST-METHOD-CALL structure, a METHOD-CALL structure, or a
228    ;;; method function for calling METHOD.
229    ;;;
230    (defun get-method-callable (method cm-args gf fmf-p method-alist wrappers)
231      (multiple-value-bind (mf real-mf-p fmf pv-cell)
232          (get-method-function method method-alist wrappers)
233        (cond (fmf
234               (let* ((next-methods (car cm-args))
235                      (next (callable-for-call-method gf (car next-methods)
236                                                      (list* (cdr next-methods)
237                                                             (cdr cm-args))
238                                                      fmf-p method-alist wrappers))
239                      (arg-info (method-function-get fmf :arg-info)))
240                 (make-fast-method-call :function fmf
241                                        :pv-cell pv-cell
242                                        :next-method-call next
243                                        :arg-info arg-info)))
244              (real-mf-p
245               (make-method-call :function mf :call-method-args cm-args))
246              (t mf))))
247    
248    (defun get-method-function (method method-alist wrappers)
249      (let ((fn (cadr (assoc method method-alist))))
250        (if fn
251            (values fn nil nil nil)
252            (multiple-value-bind (mf fmf)
253                (if (listp method)
254                    (early-method-function method)
255                    (values nil (method-fast-function method)))
256              (let ((pv-table (and fmf (method-function-pv-table fmf))))
257                (if (and fmf
258                         (not (and pv-table (pv-table-computing-cache-p pv-table)))
259                         (or (null pv-table) wrappers))
260                    (let* ((pv-wrappers (when pv-table
261                                          (pv-wrappers-from-all-wrappers
262                                           pv-table wrappers)))
263                           (pv-cell (when (and pv-table pv-wrappers)
264                                      (pv-table-lookup pv-table pv-wrappers))))
265                      (values mf t fmf pv-cell))
266                    (values
267                     (or mf (if (listp method)
268                                (setf (cadr method)
269                                      (method-function-from-fast-function fmf))
270                                (method-function method)))
271                     t nil nil)))))))
272    
273    
274    ;;;
275    ;;; Return a closure returning a FAST-METHOD-CALL instance for the
276    ;;; call of the effective method of generic function GF with body
277    ;;; BODY.
278    ;;;
279    (defun callable-generator-for-emf (gf body method-alist-p wrappers-p)
280      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
281          (get-generic-function-info gf)
282        (declare (ignore nkeys arg-info))
283        (let* ((name (if (early-gf-p gf)
284                         (early-gf-name gf)
285                         (generic-function-name gf)))
286               (arg-info (cons nreq applyp))
287               (effective-method-lambda (make-effective-method-lambda gf body)))
288          (multiple-value-bind (cfunction constants)
289              (get-function1 effective-method-lambda
290                             (lambda (form)
291                               (memf-test-converter form gf method-alist-p
292                                                    wrappers-p))
293                             (lambda (form)
294                               (memf-code-converter form gf metatypes applyp
295                                                    method-alist-p wrappers-p))
296                             (lambda (form)
297                               (memf-constant-converter form gf)))
298            (lambda (method-alist wrappers)
299              (let* ((constants
300                      (mapcar (lambda (constant)
301                                (case (car-safe constant)
302                                  (.meth.
303                                   (funcall (cdr constant) method-alist wrappers))
304                                  (.meth-list.
305                                   (mapcar (lambda (fn)
306                                             (funcall fn method-alist wrappers))
307                                           (cdr constant)))
308                                  (t constant)))
309                              constants))
310                     (function (set-function-name (apply cfunction constants)
311                                                  `(effective-method ,name))))
312                (make-fast-method-call :function function
313                                       :arg-info arg-info)))))))
314    
315    ;;;
316    ;;; Return a lambda-form for an effective method of generic function
317    ;;; GF with body BODY.
318    ;;;
319    (defun make-effective-method-lambda (gf body)
320      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
321          (get-generic-function-info gf)
322        (declare (ignore nreq nkeys arg-info))
323        (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
324              (error-p (eq (first body) '%no-primary-method))
325              (mc-args-p
326               (when (eq *boot-state* 'complete)
327                 ;; Otherwise the METHOD-COMBINATION slot is not bound.
328                 (let ((combin (generic-function-method-combination gf)))
329                   (and (long-method-combination-p combin)
330                        (long-method-combination-args-lambda-list combin))))))
331          (cond (error-p
332                 `(lambda (.pv-cell. .next-method-call. &rest .args.)
333                    (declare (ignore .pv-cell. .next-method-call.))
334                    ,body))
335                (mc-args-p
336                 (let* ((required (dfun-arg-symbol-list metatypes))
337                        (gf-args (if applyp
338                                     `(list* ,@required .dfun-rest-arg.)
339                                     `(list ,@required))))
340                   `(lambda ,ll
341                      (declare (ignore .pv-cell. .next-method-call.))
342                      (let ((.gf-args. ,gf-args))
343                        (declare (ignorable .gf-args.))
344                        ,body))))
345                (t
346                 `(lambda ,ll
347                    (declare (ignore .pv-cell. .next-method-call.))
348                    ,body))))))
349    
350    (defun memf-test-converter (form gf method-alist-p wrappers-p)
351      (case (car-safe form)
352        (call-method
353         (case (get-method-call-type gf form method-alist-p wrappers-p)
354           (fast-method-call '.fast-call-method.)
355           (t '.call-method.)))
356        (call-method-list
357         (case (get-method-list-call-type gf form method-alist-p wrappers-p)
358           (fast-method-call '.fast-call-method-list.)
359           (t '.call-method-list.)))
360        (t
361         (default-test-converter form))))
362    
363    (defun memf-code-converter (form gf metatypes applyp method-alist-p
364                                wrappers-p)
365      (case (car-safe form)
366        (call-method
367         (let ((gensym (gensym "MEMF")))
368           (values (make-emf-call metatypes applyp gensym
369                                  (get-method-call-type gf form method-alist-p
370                                                        wrappers-p))
371                   (list gensym))))
372        (call-method-list
373         (let ((gensym (gensym "MEMF"))
374               (type (get-method-list-call-type gf form method-alist-p
375                                                wrappers-p)))
376           (values `(dolist (emf ,gensym nil)
377                      ,(make-emf-call metatypes applyp 'emf type))
378                   (list gensym))))
379        (t
380         (default-code-converter form))))
381    
382    (defun memf-constant-converter (form gf)
383      (case (car-safe form)
384        (call-method
385         (list (cons '.meth.
386                     (callable-generator-for-call-method gf form))))
387        (call-method-list
388         (list (cons '.meth-list.
389                     (mapcar (lambda (form)
390                               (callable-generator-for-call-method gf form))
391                             (cdr form)))))
392        (t
393         (default-constant-converter form))))
394    
395    (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
396      (if (every (lambda (form)
397                   (eq 'fast-method-call
398                       (get-method-call-type gf form method-alist-p wrappers-p)))
399                 (cdr form))
400          'fast-method-call
401          t))
402    
403    (defun get-method-call-type (gf form method-alist-p wrappers-p)
404      (if (eq 'call-method (car-safe form))
405          (destructuring-bind (method &rest cm-args) (cdr form)
406            (declare (ignore cm-args))
407            (when method
408              (if (if (listp method)
409                      (eq (car method) :early-method)
410                      (method-p method))
411                  (if method-alist-p
412                      t
413                      (multiple-value-bind (mf fmf)
414                          (if (listp method)
415                              (early-method-function method)
416                              (values nil (method-fast-function method)))
417                        (declare (ignore mf))
418                        (let ((pv-table (and fmf (method-function-pv-table fmf))))
419                          (if (and fmf (or (null pv-table) wrappers-p))
420                              'fast-method-call
421                              'method-call))))
422                  (if (eq 'make-method (car-safe method))
423                      (get-method-call-type gf (cadr method) method-alist-p
424                                            wrappers-p)
425                      (type-of method)))))
426          'fast-method-call))
427    
428    
429    ;;; **************************************
430    ;;; Generating Callables for EMFs  *******
431    ;;; **************************************
432    
433    ;;;
434    ;;; Turned off until problems with method tracing caused by it are
435    ;;; solved (reason unknown).  Will be needed once inlining of methods
436    ;;; in effective methods and inlining of effective method in callers
437    ;;; gets accute.
438    ;;;
439    (defvar *named-emfs-p* nil)
440    
441    ;;;
442    ;;; Return a callable object for an emf of generic function GF, with
443    ;;; applicable methods METHODS.  GENERATOR is a function returned from
444    ;;; CALLABLE-GENERATOR.  Call it with two args METHOD-ALIST and
445    ;;; WRAPPERS to obtain the actual callable.
446    ;;;
447    (defun make-callable (gf methods generator method-alist wrappers)
448      (let ((callable (function-funcall generator method-alist wrappers)))
449        (set-emf-name gf methods callable)))
450    
451    ;;;
452    ;;; When *NAME-EMFS-P* is true, give the effective method represented
453    ;;; by CALLABLE a suitable global name of the form (EFFECTIVE-METHOD
454    ;;; ...).  GF is the generic function the effective method is for, and
455    ;;; METHODS is the list of applicable methods.
456    ;;;
457    (defun set-emf-name (gf methods callable)
458      (when *named-emfs-p*
459        (let ((function (typecase callable
460                          (fast-method-call (fast-method-call-function callable))
461                          (method-call (method-call-function callable))
462                          (t callable)))
463              (name (make-emf-name gf methods)))
464          (setf (fdefinition name) function)
465          (set-function-name function name)))
466      callable)
467    
468    ;;;
469    ;;; Return a name for an effective method of generic function GF,
470    ;;; composed of applicable methods METHODS.
471    ;;;
472    ;;; In general, the name cannot be based on the methods alone, because
473    ;;; that doesn't take method combination arguments into account.
474    ;;;
475    ;;; It is possible to do better for the standard method combination,
476    ;;; though.  The current name format is
477    ;;;
478    ;;;  (EFFECTIVE-METHOD gf-name around-methods before-methods
479    ;;;       primary-method after-methods)
480    ;;;
481    ;;; where each method is a list (METHOD qualifiers specializers).
482    ;;;
483    (defvar *emf-name-table* (make-hash-table :test 'equal))
484    
485    (defun make-emf-name (gf methods)
486      (let* ((early-p (early-gf-p gf))
487             (gf-name (if early-p
488                         (early-gf-name gf)
489                         (generic-function-name gf)))
490             (emf-name
491              (if (or early-p
492                      (eq (generic-function-method-combination gf)
493                          *standard-method-combination*))
494                  (let (primary around before after)
495                    (dolist (m methods)
496                      (let ((qual (if early-p
497                                      (early-method-qualifiers m)
498                                      (method-qualifiers m)))
499                            (specl (if early-p
500                                       (early-method-specializers m)
501                                       (unparse-specializers
502                                        (method-specializers m)))))
503                        (case (car-safe qual)
504                          (:around (push `(method :around ,specl) around))
505                          (:before (push `(method :before ,specl) before))
506                          (:after (push `(method :after ,specl) after))
507                          (t (push `(method ,specl) primary)))))
508                    `(effective-method ,gf-name
509                                       ,@(nreverse around)
510                                       ,@(nreverse before)
511                                       ,@(list (last primary))
512                                       ,@after))
513                  `(effective-method ,gf-name ,(gensym)))))
514        (or (gethash emf-name *emf-name-table*)
515            (setf (gethash emf-name *emf-name-table*) emf-name))))
516    
517    ;;; end of combin.lisp

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.13.2.1

  ViewVC Help
Powered by ViewVC 1.1.5