[Openmcl-devel] who-calls and eql-specializer

[Takehiko Abe]

who-calls signals error when there are calling methods
specialized on eql-specializer.

The following is my attempt to fix it.


;;; Redefines ccl::make-xref-entry and ccl::source-files-like-em
;;; so that they won't call class-name on eql-specializer.
;;;
;;; The modified parts are marked with "***".
;;;

(defun %specializer-name (specializer)
  (etypecase specializer
    (class (class-name specializer))
    (eql-specializer
     (list 'eql (eql-specializer-object specializer)))))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun make-xref-entry (input relation)
  (etypecase input
    (symbol
     (let ((type (ecase relation
                   ((:direct-calls :indirect-calls) 'function)
                   ((:binds :sets :references) 'variable)
                   ((:macro-calls) 'macro))))
       (%make-xref-entry :name input :type type)))
    (method
     (let ((name (method-name input))
           (qualifiers (method-qualifiers input))
           ;; ***
           (specializers (mapcar #'%specializer-name
                                 (method-specializers input))))
       (%make-xref-entry :name name :type 'method
                         :method-qualifiers
                         (unless (eql qualifiers t) qualifiers)
                         :method-specializers specializers)))
    (cons
     (case (car input)
       ((ppc-lap-macro compiler-macro-function)
        (%make-xref-entry :name (cadr input) :type (car input)))
       (t
        (multiple-value-bind (type name specializers qualifiers)
                             (parse-definition-spec input)
          (%make-xref-entry :name name :type type
                            :method-qualifiers
                            (unless (eql qualifiers t) qualifiers)
                            :method-specializers specializers)))))))

(defun source-files-like-em (classes qualifiers method)
  (when (do ((cls classes (cdr cls))
             (xsps (%method-specializers method) (cdr xsps)))
            ((null cls) t)
          (let ((class (car cls))(xspec (car xsps)))
            (unless (if (listp xspec)
                      (and (listp class)
                           (or (not (constantp (cadr class)))
                               ; one is evaluated the other is not
                               (eql (cadr class)(cadr xspec))))
                      ;; ***
                      (equal class (%specializer-name xspec)))
              (return nil))))
      (or (eq qualifiers t)
          (equal qualifiers (%method-qualifiers method)))))

)