diff options
Diffstat (limited to 'geiser')
| -rw-r--r-- | geiser/completion.scm | 27 | ||||
| -rw-r--r-- | geiser/doc.scm | 258 | ||||
| -rw-r--r-- | geiser/emacs.scm | 58 | ||||
| -rw-r--r-- | geiser/evaluation.scm | 144 | ||||
| -rw-r--r-- | geiser/modules.scm | 104 | ||||
| -rw-r--r-- | geiser/utils.scm | 52 | ||||
| -rw-r--r-- | geiser/xref.scm | 84 |
7 files changed, 0 insertions, 727 deletions
diff --git a/geiser/completion.scm b/geiser/completion.scm deleted file mode 100644 index d69859b..0000000 --- a/geiser/completion.scm +++ /dev/null @@ -1,27 +0,0 @@ -;;; 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/geiser/doc.scm b/geiser/doc.scm deleted file mode 100644 index 9f28f7f..0000000 --- a/geiser/doc.scm +++ /dev/null @@ -1,258 +0,0 @@ -;;; 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/geiser/emacs.scm b/geiser/emacs.scm deleted file mode 100644 index 6f2fc29..0000000 --- a/geiser/emacs.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; 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/geiser/evaluation.scm b/geiser/evaluation.scm deleted file mode 100644 index bdbcdd8..0000000 --- a/geiser/evaluation.scm +++ /dev/null @@ -1,144 +0,0 @@ -;;; 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/geiser/modules.scm b/geiser/modules.scm deleted file mode 100644 index 32b0f1f..0000000 --- a/geiser/modules.scm +++ /dev/null @@ -1,104 +0,0 @@ -;;; 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/geiser/utils.scm b/geiser/utils.scm deleted file mode 100644 index 92ed7ae..0000000 --- a/geiser/utils.scm +++ /dev/null @@ -1,52 +0,0 @@ -;;; 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/geiser/xref.scm b/geiser/xref.scm deleted file mode 100644 index 549cc94..0000000 --- a/geiser/xref.scm +++ /dev/null @@ -1,84 +0,0 @@ -;;; 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))))))) |