diff options
| -rw-r--r-- | src/geiser/completion.scm | 27 | ||||
| -rw-r--r-- | src/geiser/doc.scm | 258 | ||||
| -rw-r--r-- | src/geiser/emacs.scm | 58 | ||||
| -rw-r--r-- | src/geiser/evaluation.scm | 144 | ||||
| -rw-r--r-- | src/geiser/modules.scm | 104 | ||||
| -rw-r--r-- | src/geiser/utils.scm | 52 | ||||
| -rw-r--r-- | src/geiser/xref.scm | 84 |
7 files changed, 727 insertions, 0 deletions
diff --git a/src/geiser/completion.scm b/src/geiser/completion.scm new file mode 100644 index 0000000..d69859b --- /dev/null +++ b/src/geiser/completion.scm @@ -0,0 +1,27 @@ +;;; completion.scm -- completing known symbols and module names + +;; Copyright (C) 2009, 2012 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Mon Mar 02, 2009 02:22 + +(define-module (geiser completion) + #:export (completions module-completions) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (ice-9 session) + #:use-module (ice-9 regex)) + +(define (completions prefix) + (let ((prefix (string-append "^" (regexp-quote prefix)))) + (sort! (map symbol->string (apropos-internal prefix)) string<?))) + +(define (module-completions prefix) + (let* ((prefix (string-append "^" (regexp-quote prefix))) + (matcher (lambda (s) (string-match prefix s))) + (names (filter matcher (all-modules)))) + (sort! names string<?))) diff --git a/src/geiser/doc.scm b/src/geiser/doc.scm new file mode 100644 index 0000000..9f28f7f --- /dev/null +++ b/src/geiser/doc.scm @@ -0,0 +1,258 @@ +;;; doc.scm -- procedures providing documentation on scheme objects + +;; Copyright (C) 2009, 2010, 2018 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Sun Feb 08, 2009 18:44 + +(define-module (geiser doc) + #:export (autodoc + symbol-documentation + module-exports + object-signature) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (system vm program) + #:use-module (system vm debug) + #:use-module (ice-9 session) + #:use-module (ice-9 documentation) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:use-module (srfi srfi-1)) + +(define (autodoc ids) + (if (not (list? ids)) + '() + (map (lambda (id) (or (autodoc* id) (list id))) ids))) + +(define* (autodoc* id) + (let ((args (obj-args (symbol->object id)))) + (and args + `(,@(signature id args) + ("module" . ,(symbol-module id)))))) + +(define (object-signature name obj) + (let ((args (obj-args obj))) + (and args (signature name args)))) + +(define (value-str obj) + (format #f "~:@y" obj)) + +(define* (signature id args-list #:optional (detail #t)) + (define (arglst args kind) + (let ((args (assq-ref args kind))) + (cond ((or (not args) (null? args)) '()) + ((list? args) args) + (else (list args))))) + (define (mkargs as) + `(("required" ,@(arglst as 'required)) + ("optional" ,@(arglst as 'optional) + ,@(if (assq-ref as 'rest) (list "...") '())) + ("key" ,@(arglst as 'keyword)))) + (let* ((args-list (map mkargs (if (list? args-list) args-list '()))) + (value (and (and detail (null? args-list)) + (value-str (symbol->object id))))) + `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '())))) + +(define default-macro-args '(((required ...)))) + +(define geiser-args-key (gensym "geiser-args-key-")) + +(define (obj-args obj) + (cond ((not obj) #f) + ((or (procedure? obj) (program? obj)) + (cond ((procedure-property obj geiser-args-key)) + ((arguments obj) => + (lambda (args) + (set-procedure-property! obj geiser-args-key args) + args)) + (else #f))) + ((and (macro? obj) (macro-transformer obj)) => macro-args) + ((macro? obj) default-macro-args) + (else 'variable))) + +(define (program-arities prog) + (let ((addrs (program-address-range prog))) + (when (pair? addrs) (find-program-arities (car addrs))))) + +(define (arguments proc) + (define (p-args prog) + (let ((as (map arity-arguments-alist (or (program-arities prog) '())))) + (and (not (null? as)) as))) + (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y))))) + (cond ((is-a? proc <generic>) (generic-args proc)) + ((doc->args proc) => list) + ((procedure-property proc 'arglist) => (clist arglist->args)) + ((procedure-source proc) => (clist source->args)) + ((and (program? proc) (p-args proc))) + ((procedure-property proc 'arity) => (clist arity->args)) + (else #f))) + +(define (source->args src) + (let ((formals (cadr src))) + (cond ((list? formals) `((required . ,formals))) + ((pair? formals) + `((required . ,(car formals)) (rest . ,(cdr formals)))) + (else #f)))) + +(define (macro-args tf) + (define* (collect args #:optional (req '())) + (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f))) + ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args))) + ((and (pair? args) (symbol? (car args))) + (collect (cdr args) (cons (car args) req))) + (else #f))) + (let* ((pats (procedure-property tf 'patterns)) + (args (and pats (filter-map collect pats)))) + (or (and args (not (null? args)) args) default-macro-args))) + +(define (arity->args art) + (define (gen-arg-names count) + (map (lambda (x) '_) (iota (max count 0)))) + (let ((req (car art)) + (opt (cadr art)) + (rest (caddr art))) + `(,@(if (> req 0) + (list (cons 'required (gen-arg-names req))) + '()) + ,@(if (> opt 0) + (list (cons 'optional (gen-arg-names opt))) + '()) + ,@(if rest (list (cons 'rest 'rest)) '())))) + +(define (arglist->args arglist) + `((required . ,(car arglist)) + (optional . ,(cadr arglist)) + (keyword . ,(caddr arglist)) + (rest . ,(car (cddddr arglist))))) + +(define (doc->args proc) + ;; Guile 2.0.9+ uses the (texinfo ...) modules to produce + ;; `guile-procedures.txt', and the output has a single hyphen, whereas + ;; `makeinfo' produces two hyphens. + (define proc-rx "--? Scheme Procedure: ([^[\n]+)\n") + (define proc-rx2 "--? Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)") + (let ((doc (object-documentation proc))) + (and doc + (let ((match (or (string-match proc-rx doc) + (string-match proc-rx2 doc)))) + (and match + (parse-signature-string (match:substring match 1))))))) + +(define (parse-signature-string str) + (define opt-arg-rx "\\[([^] ]+)\\]?") + (define opt-arg-rx2 "([^ ])+\\]+") + (let ((tokens (string-tokenize str))) + (if (< (length tokens) 2) + '() + (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f)) + (cond ((null? tokens) + `((required ,@(map string->symbol (reverse! req))) + (optional ,@(map string->symbol (reverse! opt))) + ,@(if rest + (list (cons 'rest (string->symbol rest))) + '()))) + ((string=? "." (car tokens)) + (if (not (null? (cdr tokens))) + (loop (cddr tokens) req opt (cadr tokens)) + (loop '() req opt "rest"))) + ((or (string-match opt-arg-rx (car tokens)) + (string-match opt-arg-rx2 (car tokens))) + => (lambda (m) + (loop (cdr tokens) + req + (cons (match:substring m 1) opt) + rest))) + (else (loop (cdr tokens) + (cons (car tokens) req) + opt + rest))))))) + +(define (generic-args gen) + (define (src> src1 src2) + (> (length (cadr src1)) (length (cadr src2)))) + (define (src m) + (catch #t + (lambda () (method-source m)) + (lambda (k . a) #f))) + (let* ((methods (generic-function-methods gen)) + (srcs (filter identity (map src methods)))) + (cond ((and (null? srcs) + (not (null? methods)) + (method-procedure (car methods))) => arguments) + ((not (null? srcs)) (list (source->args (car (sort! srcs src>))))) + (else '(((rest . rest))))))) + +(define (symbol-documentation sym) + (let ((obj (symbol->object sym))) + (if obj + `(("signature" . ,(or (obj-signature sym obj #f) sym)) + ("docstring" . ,(docstring sym obj)))))) + +(define (docstring sym obj) + (define (valuable?) + (not (or (macro? obj) (procedure? obj) (program? obj)))) + (with-output-to-string + (lambda () + (let* ((type (cond ((macro? obj) "A macro") + ((procedure? obj) "A procedure") + ((program? obj) "A compiled program") + (else "An object"))) + (modname (symbol-module sym)) + (doc (object-documentation obj))) + (display type) + (if modname + (begin + (display " in module ") + (display modname) + (display "."))) + (newline) + (if doc (begin (newline) (display doc))) + (if (valuable?) (begin (newline) + (display "Value:") + (newline) + (display " ") + (display (value-str obj)))))))) + +(define* (obj-signature sym obj #:optional (detail #t)) + (let ((args (obj-args obj))) + (and args (signature sym args detail)))) + +(define (module-exports mod-name) + (define elt-sort (make-symbol-sort car)) + (let* ((mod (catch #t + (lambda () (resolve-interface mod-name)) + (lambda args (resolve-module mod-name)))) + (elts (hash-fold classify-module-object + (list '() '() '()) + (module-obarray mod))) + (elts (map elt-sort elts)) + (subs (map (lambda (m) (list (module-name m))) + (submodules (resolve-module mod-name #f))))) + (list (cons "modules" subs) + (cons "procs" (car elts)) + (cons "syntax" (cadr elts)) + (cons "vars" (caddr elts))))) + +(define (classify-module-object name var elts) + (let ((obj (and (variable-bound? var) + (variable-ref var)))) + (cond ((or (not obj) (module? obj)) elts) + ((or (procedure? obj) (program? obj)) + (list (cons (list name `("signature" . ,(obj-signature name obj))) + (car elts)) + (cadr elts) + (caddr elts))) + ((macro? obj) + (list (car elts) + (cons (list name `("signature" . ,(obj-signature name obj))) + (cadr elts)) + (caddr elts))) + (else (list (car elts) + (cadr elts) + (cons (list name) (caddr elts))))))) diff --git a/src/geiser/emacs.scm b/src/geiser/emacs.scm new file mode 100644 index 0000000..6f2fc29 --- /dev/null +++ b/src/geiser/emacs.scm @@ -0,0 +1,58 @@ +;;; emacs.scm -- procedures for emacs interaction: entry point + +;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Sun Feb 08, 2009 18:39 + +(define-module (geiser emacs) + #:use-module (ice-9 match) + #:use-module (system repl command) + #:use-module (system repl error-handling) + #:use-module (system repl server) + #:use-module (geiser evaluation) + #:use-module ((geiser modules) #:renamer (symbol-prefix-proc 'ge:)) + #:use-module ((geiser completion) #:renamer (symbol-prefix-proc 'ge:)) + #:use-module ((geiser xref) #:renamer (symbol-prefix-proc 'ge:)) + #:use-module ((geiser doc) #:renamer (symbol-prefix-proc 'ge:))) + +(define this-module (resolve-module '(geiser emacs))) + +(define-meta-command ((geiser-no-values geiser) repl) + "geiser-no-values +No-op command used internally by Geiser." + (values)) + +(define-meta-command ((geiser-newline geiser) repl) + "geiser-newline +Meta-command used by Geiser to emit a new line." + (newline)) + +(define-meta-command ((geiser-eval geiser) repl (mod form args) . rest) + "geiser-eval module form args () +Meta-command used by Geiser to evaluate and compile code." + (if (null? args) + (call-with-error-handling + (lambda () (ge:compile form mod))) + (let ((proc (eval form this-module))) + (ge:eval `(,proc ,@args) mod)))) + +(define-meta-command ((geiser-load-file geiser) repl file) + "geiser-load-file file +Meta-command used by Geiser to load and compile files." + (call-with-error-handling + (lambda () (ge:compile-file file)))) + + +(define-meta-command ((geiser-start-server geiser) repl) + "geiser-start-server +Meta-command used by Geiser to start a REPL server." + (let* ((sock (make-tcp-server-socket #:port 0)) + (port (sockaddr:port (getsockname sock)))) + (spawn-server sock) + (write (list 'port port)) + (newline))) diff --git a/src/geiser/evaluation.scm b/src/geiser/evaluation.scm new file mode 100644 index 0000000..bdbcdd8 --- /dev/null +++ b/src/geiser/evaluation.scm @@ -0,0 +1,144 @@ +;;; evaluation.scm -- evaluation, compilation and macro-expansion + +;; Copyright (C) 2009, 2010, 2011, 2013, 2015 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Mon Mar 02, 2009 02:46 + +(cond-expand + (guile-2.2 + (define-module (geiser evaluation) + #:export (ge:compile + ge:eval + ge:macroexpand + ge:compile-file + ge:load-file + ge:set-warnings + ge:add-to-load-path) + #:use-module (geiser modules) + #:use-module (srfi srfi-1) + #:use-module (language tree-il) + #:use-module (system base compile) + #:use-module (system base message) + #:use-module (system base pmatch) + #:use-module (system vm program) + #:use-module (ice-9 pretty-print) + #:use-module (system vm loader))) + (else + (define-module (geiser evaluation) + #:export (ge:compile + ge:eval + ge:macroexpand + ge:compile-file + ge:load-file + ge:set-warnings + ge:add-to-load-path) + #:use-module (geiser modules) + #:use-module (srfi srfi-1) + #:use-module (language tree-il) + #:use-module (system base compile) + #:use-module (system base message) + #:use-module (system base pmatch) + #:use-module (system vm program) + #:use-module (ice-9 pretty-print)))) + + +(define compile-opts '()) +(define compile-file-opts '()) + +(define default-warnings '(arity-mismatch unbound-variable format)) +(define verbose-warnings `(unused-variable ,@default-warnings)) + +(define (ge:set-warnings wl) + (let* ((warns (cond ((list? wl) wl) + ((symbol? wl) (case wl + ((none nil null) '()) + ((medium default) default-warnings) + ((high verbose) verbose-warnings) + (else '()))) + (else '()))) + (fwarns (if (memq 'unused-variable warns) + (cons 'unused-toplevel warns) + warns))) + (set! compile-opts (list #:warnings warns)) + (set! compile-file-opts (list #:warnings fwarns)))) + +(ge:set-warnings 'none) + +(define (call-with-result thunk) + (letrec* ((result #f) + (output + (with-output-to-string + (lambda () + (with-fluids ((*current-warning-port* (current-output-port)) + (*current-warning-prefix* "")) + (with-error-to-port (current-output-port) + (lambda () (set! result + (map object->string (thunk)))))))))) + (write `((result ,@result) (output . ,output))) + (newline))) + +(define (ge:compile form module) + (compile* form module compile-opts)) + +(define (compile* form module-name opts) + (let* ((module (or (find-module module-name) (current-module))) + (ev (lambda () + (call-with-values + (lambda () + (let* ((to (cond-expand (guile-2.2 'bytecode) + (else 'objcode))) + (cf (cond-expand (guile-2.2 load-thunk-from-memory) + (else make-program))) + (o (compile form + #:to to + #:env module + #:opts opts)) + (thunk (cf o))) + (start-stack 'geiser-evaluation-stack + (eval `(,thunk) module)))) + (lambda vs vs))))) + (call-with-result ev))) + +(define (ge:eval form module-name) + (let* ((module (or (find-module module-name) (current-module))) + (ev (lambda () + (call-with-values + (lambda () (eval form module)) + (lambda vs vs))))) + (call-with-result ev))) + +(define (ge:compile-file path) + (call-with-result + (lambda () + (let ((cr (compile-file path + #:canonicalization 'absolute + #:opts compile-file-opts))) + (and cr + (list (object->string (save-module-excursion + (lambda () (load-compiled cr)))))))))) + +(define ge:load-file ge:compile-file) + +(define (ge:macroexpand form . all) + (let ((all (and (not (null? all)) (car all)))) + (with-output-to-string + (lambda () + (pretty-print (tree-il->scheme (macroexpand form))))))) + +(define (add-to-list lst dir) + (and (not (member dir lst)))) + +(define (ge:add-to-load-path dir) + (and (file-is-directory? dir) + (let ((in-lp (member dir %load-path)) + (in-clp (member dir %load-compiled-path))) + (when (not in-lp) + (set! %load-path (cons dir %load-path))) + (when (not in-clp) + (set! %load-compiled-path (cons dir %load-compiled-path))) + (or in-lp in-clp)))) diff --git a/src/geiser/modules.scm b/src/geiser/modules.scm new file mode 100644 index 0000000..32b0f1f --- /dev/null +++ b/src/geiser/modules.scm @@ -0,0 +1,104 @@ +;;; modules.scm -- module metadata + +;; Copyright (C) 2009, 2010, 2011, 2018 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Mon Mar 02, 2009 02:00 + +(define-module (geiser modules) + #:export (symbol-module + program-module + module-name? + module-path + find-module + all-modules + submodules + module-location) + #:use-module (geiser utils) + #:use-module (system vm program) + #:use-module (system vm debug) + #:use-module (ice-9 regex) + #:use-module (ice-9 session) + #:use-module (srfi srfi-1)) + +;; Return hash table mapping filename to list of modules defined in that +;; file. H/t andy wingo. +(define (fill-file->module-mapping! ret) + (define (record-module m) + (let ((f (module-filename m))) + (hash-set! ret f (cons m (hash-ref ret f '()))))) + (define (visit-module m) + (record-module m) + (hash-for-each (lambda (k v) (visit-module v)) + (module-submodules m))) + (visit-module (resolve-module '() #f)) + ret) + +(define file->modules (fill-file->module-mapping! (make-hash-table))) + +(define (program-file p) + (let ((src (program-source p 0))) + (and (pair? src) (cadr src)))) + +(define (program-module p) + (let* ((f (program-file p)) + (mods (or (hash-ref file->modules f) + (hash-ref (fill-file->module-mapping! file->modules) f)))) + (and (pair? mods) (not (null? mods)) (car mods)))) + +(define (module-name? module-name) + (and (list? module-name) + (not (null? module-name)) + (every symbol? module-name))) + +(define (symbol-module sym . all) + (and sym + (catch 'module-name + (lambda () + (apropos-fold (lambda (module name var init) + (if (eq? name sym) + (throw 'module-name (module-name module)) + init)) + #f + (regexp-quote (symbol->string sym)) + (if (or (null? all) (not (car all))) + (apropos-fold-accessible (current-module)) + apropos-fold-all))) + (lambda (key . args) + (and (eq? key 'module-name) (car args)))))) + +(define (module-location name) + (make-location (module-path name) #f)) + +(define (find-module mod-name) + (and (module-name? mod-name) + (resolve-module mod-name #f #:ensure #f))) + +(define (module-path module-name) + (and (module-name? module-name) + (or ((@@ (ice-9 session) module-filename) module-name) + (module-filename (resolve-module module-name #f))))) + +(define (submodules mod) + (hash-map->list (lambda (k v) v) (module-submodules mod))) + +(define (root-modules) + (submodules (resolve-module '() #f))) + +(define (all-modules) + (define (maybe-name m) + (and (module-kind m) (format #f "~A" (module-name m)))) + (let* ((guile (resolve-module '(guile))) + (roots (remove (lambda (m) (eq? m guile)) (root-modules))) + (children (append-map all-child-modules roots))) + (cons "(guile)" (filter-map maybe-name children)))) + +(define* (all-child-modules mod #:optional (seen '())) + (let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod)))) + (fold (lambda (m all) (append (all-child-modules m all) all)) + (list mod) + cs))) diff --git a/src/geiser/utils.scm b/src/geiser/utils.scm new file mode 100644 index 0000000..92ed7ae --- /dev/null +++ b/src/geiser/utils.scm @@ -0,0 +1,52 @@ +;;; utils.scm -- utility functions + +;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Mon Mar 02, 2009 01:48 + +(define-module (geiser utils) + #:export (make-location + symbol->object + pair->list + sort-symbols! + make-symbol-sort + gensym?) + #:use-module (ice-9 regex)) + +(define (symbol->object sym) + (and (symbol? sym) + (module-defined? (current-module) sym) + (module-ref (current-module) sym))) + +(define (pair->list pair) + (let loop ((d pair) (s '())) + (cond ((null? d) (reverse! s)) + ((symbol? d) (reverse! (cons d s))) + (else (loop (cdr d) (cons (car d) s)))))) + +(define (make-location file line) + (list (cons "file" (if (string? file) file '())) + (cons "line" (if (number? line) (+ 1 line) '())))) + +(define (sort-symbols! syms) + (let ((cmp (lambda (l r) + (string<? (symbol->string l) (symbol->string r))))) + (sort! syms cmp))) + +(define (make-symbol-sort sel) + (let ((cmp (lambda (a b) + (string<? (symbol->string (sel a)) + (symbol->string (sel b)))))) + (lambda (syms) + (sort! syms cmp)))) + +(define (gensym? sym) + (and (symbol? sym) (gensym-name? (format #f "~A" sym)))) + +(define (gensym-name? name) + (and (string-match "^#[{]" name) #t)) diff --git a/src/geiser/xref.scm b/src/geiser/xref.scm new file mode 100644 index 0000000..549cc94 --- /dev/null +++ b/src/geiser/xref.scm @@ -0,0 +1,84 @@ +;;; xref.scm -- cross-referencing utilities + +;; Copyright (C) 2009, 2010, 2020 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Mon Mar 02, 2009 02:37 + +(define-module (geiser xref) + #:export (symbol-location + generic-methods + callers + callees + find-file) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (geiser doc) + #:use-module (oop goops) + #:use-module (system xref) + #:use-module (system vm program)) + +(define (symbol-location sym) + (let ((obj (symbol->object sym))) + (cond ((program? obj) (program-location obj)) + ((symbol-module sym) => module-location) + (else '())))) + +(define (generic-methods sym) + (let* ((gen (symbol->object sym)) + (methods (if (is-a? gen <generic>) + (generic-function-methods gen) + '()))) + (filter (lambda (x) (not (null? x))) + (map (lambda (m) + (make-xref (method-procedure m) sym (symbol-module sym))) + methods)))) + +(define (make-xref proc name module) + (and proc + `(("location" . ,(or (program-location proc) (symbol-location name))) + ("signature" . ,(object-signature name proc)) + ("module" . ,(or module '()))))) + +(define (program-location p) + (cond ((not (program? p)) #f) + ((program-source p 0) => + (lambda (s) (make-location (program-path p) (source:line s)))) + ((program-path p) => (lambda (s) (make-location s #f))) + (else #f))) + +(define (program-path p) + (let* ((mod (program-module p)) + (name (and (module? mod) (module-name mod)))) + (and name (module-path name)))) + +(define (procedure-xref proc . mod-name) + (let* ((proc-name (or (procedure-name proc) '<anonymous>)) + (mod-name (if (null? mod-name) + (symbol-module proc-name) + (car mod-name)))) + (make-xref proc proc-name mod-name))) + +(define (callers sym) + (let ((mod (symbol-module sym #t))) + (and mod + (apply append (map (lambda (procs) + (map (lambda (proc) + (procedure-xref proc (car procs))) + (cdr procs))) + (procedure-callers (cons mod sym))))))) + +(define (callees sym) + (let ((obj (symbol->object sym))) + (and obj + (map procedure-xref (procedure-callees obj))))) + +(define (find-file path) + (let loop ((dirs %load-path)) + (if (null? dirs) #f + (let ((candidate (string-append (car dirs) "/" path))) + (if (file-exists? candidate) candidate (loop (cdr dirs))))))) |