Changeset 13581


Ignore:
Timestamp:
09/07/11 20:34:40 (10 years ago)
Author:
ehuelsmann
Message:

Extract a function.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13569 r13581  
    10001000
    10011001(defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR"))
     1002
     1003(defun wrap-with-call-method-macro (gf forms)
     1004  `(macrolet
     1005       ((call-method (method &optional next-method-list)
     1006          `(funcall
     1007            ,(cond
     1008              ((listp method)
     1009               (assert (eq (first method) 'make-method))
     1010               ;; by generating an inline expansion we prevent allocation
     1011               ;; of a method instance which will be discarded immediately
     1012               ;; after reading the METHOD-FUNCTION slot
     1013               (compute-method-function
     1014                    `(lambda (&rest ,(gensym))
     1015                       ;;### FIXME
     1016                       ;; the MAKE-METHOD body form gets evaluated in
     1017                       ;; the null lexical environment augmented
     1018                       ;; with a binding for CALL-METHOD
     1019                       ;; ... it's the latter we're not doing here...
     1020                       ,(second method))))
     1021              (t (%method-function method)))
     1022            args
     1023            ,(unless (null next-method-list)
     1024                     ;; by not generating an emf when there are no next methods,
     1025                     ;; we ensure next-method-p returns NIL
     1026                     (compute-effective-method-function
     1027                        ,gf (process-next-method-list next-method-list))))))
     1028     ,@forms))
    10021029
    10031030(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
     
    20612088                 `(lambda (args)
    20622089                    (let ((gf-args-var args))
    2063                       (macrolet ((call-method (method &optional next-method-list)
    2064                                    `(funcall
    2065                                      ,(cond
    2066                                        ((listp method)
    2067                                         (assert (eq (first method) 'make-method))
    2068                                         ;; by generating an inline expansion we prevent allocation
    2069                                         ;; of a method instance which will be discarded immediately
    2070                                         ;; after reading the METHOD-FUNCTION slot
    2071                                         (compute-method-function `(lambda (&rest ,(gensym))
    2072                                                    ;;### FIXME
    2073                                                    ;; the MAKE-METHOD body form gets evaluated in
    2074                                                    ;; the null lexical environment augmented
    2075                                                    ;; with a binding for CALL-METHOD
    2076                                                    ;; ... it's the latter we're not doing here...
    2077                                                                     ,(second method))))
    2078                                        (t (%method-function method)))
    2079                                      args
    2080                                      ,(unless (null next-method-list)
    2081                                         ;; by not generating an emf when there are no next methods,
    2082                                         ;; we ensure next-method-p returns NIL
    2083                                         (compute-effective-method-function ,gf
    2084                                            (process-next-method-list next-method-list))))))
    2085                         ,result)))))))
     2090                      ,(wrap-with-call-method-macro gf (list result))))))))
    20862091      (t
    20872092       (let ((mc-obj (get mc-name 'method-combination-object)))
Note: See TracChangeset for help on using the changeset viewer.