[Openmcl-devel] compute-applicable-methods-using-classes

[Marco Baringer]

this symbol is exported from openmcl-mop but isn't implmented. i cooked
up a quick and dirty implementation in just a few minutes, is there a
reason this method doesn't exist? is my quick implementian (based on a
brutal cut 'n paste of %method-applicable-p and
%compute-applicable-methods*) missing something major?

-- 
-Marco
Ring the bells that still can ring.
Forget the perfect offering.
There is a crack in everything.
That's how the light gets in.
	-Leonard Cohen
-------------- next part --------------
(defun swank-mop:compute-applicable-methods-using-classes (gf args)
  (let* ((methods (ccl::%gf-methods gf))
         (args-length (length args))
         (bits (ccl::inner-lfun-bits gf))
         arg-count res)
    (when methods
      (setq arg-count (length (ccl::%method-specializers (car methods))))
      (unless (<= arg-count args-length)
        (error "Too few args to ~s" gf))
      (unless (or (logbitp ccl::$lfbits-rest-bit bits)
                  (logbitp ccl::$lfbits-restv-bit bits)
                  (logbitp ccl::$lfbits-keys-bit bits)
                  (<= args-length 
                      (+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits))))
        (error "Too many args to ~s" gf))
      (let ((cpls (make-list arg-count)))
        (declare (dynamic-extent cpls))
        (do* ((args-tail args (cdr args-tail))
              (cpls-tail cpls (cdr cpls-tail)))
             ((null cpls-tail))
          (setf (car cpls-tail)
                (ccl::%class-precedence-list (car args-tail))))
        (flet ((%method-applicable-p (method args cpls)
                 (do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs))
                       (args args (ccl::%cdr args))
                       (cpls cpls (ccl::%cdr cpls)))
                      ((null specs) t)
                   (let ((spec (ccl::%car specs)))
                     (if (typep spec 'ccl::eql-specializer)
                         (unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec)))
                           (return nil))
                         (unless (ccl:memq spec (ccl::%car cpls))
                           (return nil)))))))
          (dolist (m methods)
            (if (%method-applicable-p m args cpls)
                (push m res))))
        (ccl::sort-methods res cpls (ccl::%gf-precedence-list gf))))))