xref.scm (2903B)
1 ;;; xref.scm -- cross-referencing utilities 2 3 ;; Copyright (C) 2009, 2010, 2020 Jose Antonio Ortega Ruiz 4 5 ;; This program is free software; you can redistribute it and/or 6 ;; modify it under the terms of the Modified BSD License. You should 7 ;; have received a copy of the license along with this program. If 8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. 9 10 ;; Start date: Mon Mar 02, 2009 02:37 11 12 (define-module (geiser xref) 13 #:export (symbol-location 14 generic-methods 15 callers 16 callees 17 find-file) 18 #:use-module (geiser utils) 19 #:use-module (geiser modules) 20 #:use-module (geiser doc) 21 #:use-module (oop goops) 22 #:use-module (system xref) 23 #:use-module (system vm program)) 24 25 (define (symbol-location sym) 26 (let ((obj (symbol->object sym))) 27 (cond ((program? obj) (program-location obj)) 28 ((symbol-module sym) => module-location) 29 (else '())))) 30 31 (define (generic-methods sym) 32 (let* ((gen (symbol->object sym)) 33 (methods (if (is-a? gen <generic>) 34 (generic-function-methods gen) 35 '()))) 36 (filter (lambda (x) (not (null? x))) 37 (map (lambda (m) 38 (make-xref (method-procedure m) sym (symbol-module sym))) 39 methods)))) 40 41 (define (make-xref proc name module) 42 (and proc 43 `(("location" . ,(or (program-location proc) (symbol-location name))) 44 ("signature" . ,(object-signature name proc)) 45 ("module" . ,(or module '()))))) 46 47 (define (program-location p) 48 (cond ((not (program? p)) #f) 49 ((program-source p 0) => 50 (lambda (s) (make-location (program-path p) (source:line s)))) 51 ((program-path p) => (lambda (s) (make-location s #f))) 52 (else #f))) 53 54 (define (program-path p) 55 (let* ((mod (program-module p)) 56 (name (and (module? mod) (module-name mod)))) 57 (and name (module-path name)))) 58 59 (define (procedure-xref proc . mod-name) 60 (let* ((proc-name (or (procedure-name proc) '<anonymous>)) 61 (mod-name (if (null? mod-name) 62 (symbol-module proc-name) 63 (car mod-name)))) 64 (make-xref proc proc-name mod-name))) 65 66 (define (callers sym) 67 (let ((mod (symbol-module sym #t))) 68 (and mod 69 (apply append (map (lambda (procs) 70 (map (lambda (proc) 71 (procedure-xref proc (car procs))) 72 (cdr procs))) 73 (procedure-callers (cons mod sym))))))) 74 75 (define (callees sym) 76 (let ((obj (symbol->object sym))) 77 (and obj 78 (map procedure-xref (procedure-callees obj))))) 79 80 (define (find-file path) 81 (let loop ((dirs %load-path)) 82 (if (null? dirs) #f 83 (let ((candidate (string-append (car dirs) "/" path))) 84 (if (file-exists? candidate) candidate (loop (cdr dirs)))))))