From aab5226dfe937861c54729744e8add15d931f758 Mon Sep 17 00:00:00 2001
From: jao <jao@gnu.org>
Date: Mon, 20 Jul 2020 04:41:00 +0100
Subject: geiser -> src
---
src/geiser/completion.scm | 27 +++++
src/geiser/doc.scm | 258 ++++++++++++++++++++++++++++++++++++++++++++++
src/geiser/emacs.scm | 58 +++++++++++
src/geiser/evaluation.scm | 144 ++++++++++++++++++++++++++
src/geiser/modules.scm | 104 +++++++++++++++++++
src/geiser/utils.scm | 52 ++++++++++
src/geiser/xref.scm | 84 +++++++++++++++
7 files changed, 727 insertions(+)
create mode 100644 src/geiser/completion.scm
create mode 100644 src/geiser/doc.scm
create mode 100644 src/geiser/emacs.scm
create mode 100644 src/geiser/evaluation.scm
create mode 100644 src/geiser/modules.scm
create mode 100644 src/geiser/utils.scm
create mode 100644 src/geiser/xref.scm
(limited to 'src/geiser')
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)))))))
--
cgit v1.2.3