Changeset 7319

Sep 29, 2007, 3:52:49 AM (12 years ago)

Fix an obscure method combination bug in l1-dcode.lisp that's been
there since Gail and I first implemented CLOS for MCL in 1990 or

compute-method-list takes a list of possibly applicable methods,
separates it up into before, after, around, and primary methods, and
trims the tail of the around/primary methods at the point where
there's no more call-next-method. Thing is, unless we're computing the
methods for the last specialized argument, those methods are only
POSSIBLY applicable. Some of them might not be. Hence, except for the
final specialized argument, when sub-dispatch? is false, only if no
around method does call-next-method will it be impossible to reach the
primary methods, and we can't trim the primary methods at all.

This fixes Gary Palter's no-applicable-method bug in the application
conversion he's working on.

1 edited


  • trunk/ccl/level-1/l1-dcode.lisp

    r7069 r7319  
    10971097                                                       (ok-if-no-primaries
    10981098                                                        (null methods)))
    1099   (let ((method-list (and methods (compute-method-list methods))))
     1099  (let ((method-list (and methods (compute-method-list methods nil))))
    11001100    (if method-list                 ; no applicable primary methods
    11011101      (if (atom method-list)
    11661166;;; %%before-and-after-combined-method-dcode or a single method, or
    11671167;;; NIL if there are no applicable primaries
    1168 (defun compute-method-list (methods)
     1168(defun compute-method-list (methods &optional (sub-dispatch? t))
    11691169  (let (arounds befores primaries afters qs)
    11701170    (dolist (m methods)
    11821182                                      (car qs) :before :after :around))))
    11831183        (push m primaries)))
    1184     (setq primaries (nremove-uncallable-next-methods (nreverse primaries))
    1185           arounds (nremove-uncallable-next-methods (nreverse arounds))
    1186           befores (nreverse befores))     
     1184    (setq primaries (nreverse primaries)
     1185          arounds (nreverse arounds)
     1186          befores (nreverse befores))
     1187    (unless sub-dispatch?
     1188      (setq primaries (nremove-uncallable-next-methods primaries)
     1189            arounds (nremove-uncallable-next-methods arounds)))
    11871190    (flet ((next-method-bit-p (method)
    11881191                              (logbitp $lfbits-nextmeth-bit
    11891192                                       (lfun-bits (%method.function method)))))
    11901193      (unless (null primaries)            ; return NIL if no applicable primary methods
    1191         (when (and arounds (not (next-method-bit-p (car (last arounds)))))
     1194        (when (and arounds
     1195                   (not sub-dispatch?)
     1196                   (not (next-method-bit-p (car (last arounds)))))
    11921197          ;; Arounds don't call-next-method, can't get to befores,
    11931198          ;; afters, or primaries
    11991204                 (progn
    12001205                   (when arounds
    1201                      (setq primaries (nremove-uncallable-next-methods
    1202                                       (nconc arounds primaries))
    1203                            arounds nil))
     1206                     (setq primaries (nconc arounds primaries)
     1207                           arounds nil)
     1208                     (unless sub-dispatch?
     1209                       (setq primaries (nremove-uncallable-next-methods primaries))))
    12041210                   t)
    12051211                 (null (cdr primaries))
    13721378                              cpls
    13731379                              precedence-list))
    1374                (method-list (and standard-mc? (compute-method-list sorted-methods))))
     1380               (method-list (and standard-mc? (compute-method-list sorted-methods sub-dispatch?))))
    13751381          (when (or (not standard-mc?)
    13761382                    (memq method-list this-element-methods)
Note: See TracChangeset for help on using the changeset viewer.