Changeset 12329


Ignore:
Timestamp:
Jun 29, 2009, 6:35:04 PM (10 years ago)
Author:
gz
Message:

Extend find-definition-sources to accept named objects in addition to names, handle anonymous functions, and obey *direct-methods-only*. Change the latter to default to t

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/source-files.lisp

    r12327 r12329  
    3636(defgeneric name-of (thing)
    3737  (:method ((thing t)) thing)
     38  (:method ((thing method-function)) (name-of (%method-function-method thing)))
    3839  (:method ((thing function)) (name-of (function-name thing)))
    3940  (:method ((thing method)) (method-name thing))
     
    4950
    5051
    51 (defvar *direct-methods-only* nil
     52(defvar *direct-methods-only* t
    5253  "If true, method name source location lookup will find direct methods only.  If false,
    5354   include all applicable methods")
     
    401402
    402403
     404;; Some objects (specifically functions) have source location information associated with the
     405;; object itself, in addition to any source locations associated with its definition.  This
     406;; allows us to find source for, e.g., anonymous functions.
     407(defgeneric get-object-sources (thing)
     408  ;; returns a list of entries ((a-type . a-name) source . previous-sources)
     409  (:method ((thing t)) nil)
     410  (:method ((fn function))
     411    (let ((source (function-source-note fn)))
     412      (when source
     413        (list (list* (cons *function-definition-type* (or (name-of fn) fn)) source nil)))))
     414  (:method ((fn method-function))
     415    (let ((source (function-source-note fn)))
     416      (when source
     417        (list (list* (cons *method-definition-type* (%method-function-method fn)) source nil)))))
     418  (:method ((m method))
     419    (get-object-sources (method-function m))))
     420
    403421(defun find-definition-sources (name &optional (type t))
    404422  "Returns a list of entries ((a-type . a-name) source . previous-sources), where
    405423a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of
    406424NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME).
    407 The list is guaranteed freshly consed (ie suitable for nconc'ing)."
    408   (let* ((dt (definition-type-instance type))
    409          (dt-class (class-of dt))
    410          (seen-dts nil)
    411          (matches nil))
    412     (with-lock-grabbed (*source-files-lock*)
    413       (loop for (nil . dt) in *definition-types*
    414             when (and (typep dt dt-class) (not (memq dt seen-dts)))
    415               do (let* ((key (definition-base-name dt name))
    416                         (all (%source-file-entries key)))
    417                    (push dt seen-dts)
    418                    (loop for entry in all
    419                          when (and (eq dt (def-source-entry.type key entry))
    420                                    (or (eq name key) ;; e.g. all methods on a gf
    421                                        (definition-same-p dt name (def-source-entry.name key entry))))
    422                            do (multiple-value-bind (type name files)
    423                                   (decode-def-source-entry key entry)
    424                                 (push (cons (cons type name) files) matches))))))
     425
     426If NAME is not a cons or symbol, it's assumed to be an object (e.g. class or
     427function) whose source location we try to heuristically locate, usually by looking up
     428the sources of its name.
     429
     430If NAME is a method name and *DIRECT-METHODS-ONLY* is false, will also locate all
     431applicable methods.
     432
     433The returned list is guaranteed freshly consed (ie suitable for nconc'ing)."
     434
     435  (let* ((dt-class (class-of (definition-type-instance type)))
     436         (matches (get-object-sources name)))
     437    (if matches
     438      (setq matches (delete-if-not (lambda (info) (typep (caar info) dt-class)) matches))
     439      ;; No intrinsic source info for the thing itself, look it up by name.
     440      (let (seen-dts implicit-type implicit-dt-class implicit-name)
     441        (typecase name
     442          (method
     443             (setq implicit-type 'method implicit-name name))
     444          (method-function
     445             (setq implicit-type 'method implicit-name (%method-function-method name)))
     446          (function
     447             (setq implicit-type 'function implicit-name (name-of name)))
     448          (method-combination
     449             (setq implicit-type 'method-combination implicit-name (name-of name)))
     450          (package
     451             (setq implicit-type 'package implicit-name (name-of name)))
     452          (class
     453             (setq implicit-type 'class implicit-name (name-of name)))
     454          (t
     455             (setq implicit-type t implicit-name name)))
     456        (setq implicit-dt-class (class-of (definition-type-instance implicit-type)))
     457        (with-lock-grabbed (*source-files-lock*)
     458          (loop for (nil . dt) in *definition-types*
     459                when (and (typep dt dt-class) (typep dt implicit-dt-class) (not (memq dt seen-dts)))
     460                  do (let* ((key (definition-base-name dt implicit-name))
     461                            (all (%source-file-entries key)))
     462                       (push dt seen-dts)
     463                       (loop for entry in all
     464                             when (and (eq dt (def-source-entry.type key entry))
     465                                       (or (eq implicit-name key) ;; e.g. all methods on a gf
     466                                           (definition-same-p dt implicit-name (def-source-entry.name key entry))))
     467                               do (multiple-value-bind (type name files)
     468                                      (decode-def-source-entry key entry)
     469                                    (push (cons (cons type name) files) matches))))))))
     470
     471    ;; include indirect applicable methods.  Who uses this case?
     472    (when (and (eq type 'method)
     473               (not (typep name 'method))
     474               (not *direct-methods-only*))
     475      (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name)
     476        (when sym
     477          (loop for m in (find-applicable-methods sym specializers qualifiers)
     478                unless (definition-same-p *method-definition-type* m name)
     479                  do (setq matches (nconc (find-definition-sources m 'method) matches))))))
    425480    matches))
    426 
    427481
    428482;;; backward compatibility
     
    546600(defun get-source-files-with-types (name &optional (type t))
    547601  (let ((list (find-definition-sources name type)))
    548     (declare (special *direct-methods-only*))
    549     ;; include indirect applicable methods.  Who uses this case?
    550     (when (and (eq type 'method)
    551                (not (typep name 'method))
    552                (not *direct-methods-only*))
    553       (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name)
    554         (when sym
    555           (loop for m in (find-applicable-methods sym specializers qualifiers)
    556                 unless (definition-same-p *method-definition-type* m name)
    557                   do (setq list (nconc (find-definition-sources m 'method) list))))))
    558602    ;; Convert to old format, (type-or-name . file)
    559603    (loop for ((dt . full-name) . sources) in list
     
    589633    (get-source-files-with-types name type)))
    590634
    591 
    592 #|
    593 ;; For working-0711 versions of slime, but this doesn't actually work since
    594 ;; source-note representations are not compatible
    595 
    596 (defun find-definitions-for-name (name &optional (type-name t))
    597   "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
    598   (let ((definitions ()))
    599     (loop for ((dt . full-name) . sources) in (find-definition-sources name type-name)
    600           as last-source = (find-if-not #'null sources)
    601           do (when last-source
    602                (push (list dt full-name last-source) definitions)))
    603     definitions))
    604 
    605 (defun find-simple-definitions-for-name (name)
    606   (let* ((result (find-definitions-for-name name)))
    607     (dolist (pair result result)
    608       (let* ((dt (car pair)))
    609         (when (typep dt 'definition-type)
    610           (setf (car pair) (definition-type-name dt)))))))
    611 |#
    612635
    613636;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Note: See TracChangeset for help on using the changeset viewer.