Remove ignored files

elpa/geiser-20180626.440/scheme/guile/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<?)))

elpa/geiser-20180626.440/scheme/guile/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)))))))

elpa/geiser-20180626.440/scheme/guile/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)))

elpa/geiser-20180626.440/scheme/guile/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))))

elpa/geiser-20180626.440/scheme/guile/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)))

elpa/geiser-20180626.440/scheme/guile/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))

elpa/geiser-20180626.440/scheme/guile/geiser/xref.scm

@@ -0,0 +1,84 @@
+;;; xref.scm -- cross-referencing utilities
+
+;; Copyright (C) 2009, 2010 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)
+  (cond ((symbol-module sym) => module-location)
+        (else (let ((obj (symbol->object sym)))
+                (or (and (program? obj) (program-location obj))
+                    '())))))
+
+(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)))))))