summaryrefslogtreecommitdiff
path: root/scheme/guile
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-03-02 03:13:59 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-03-02 03:13:59 +0100
commit1f80c5048e78d0251c18634b8bf7d3f8ea4733b0 (patch)
tree53f3731ffe00a9c5f361398b086d325ec213c7e0 /scheme/guile
parentab27ee71db711b8295dfb6e9f89d059d2310cc5e (diff)
downloadgeiser-chez-1f80c5048e78d0251c18634b8bf7d3f8ea4733b0.tar.gz
geiser-chez-1f80c5048e78d0251c18634b8bf7d3f8ea4733b0.tar.bz2
Breakdown of schemeland into neat submodules.
Diffstat (limited to 'scheme/guile')
-rw-r--r--scheme/guile/geiser/completion.scm56
-rw-r--r--scheme/guile/geiser/doc.scm (renamed from scheme/guile/geiser/introspection.scm)141
-rw-r--r--scheme/guile/geiser/emacs.scm128
-rw-r--r--scheme/guile/geiser/evaluation.scm144
-rw-r--r--scheme/guile/geiser/modules.scm102
-rw-r--r--scheme/guile/geiser/utils.scm53
-rw-r--r--scheme/guile/geiser/xref.scm37
7 files changed, 417 insertions, 244 deletions
diff --git a/scheme/guile/geiser/completion.scm b/scheme/guile/geiser/completion.scm
new file mode 100644
index 0000000..4906368
--- /dev/null
+++ b/scheme/guile/geiser/completion.scm
@@ -0,0 +1,56 @@
+;; completion.scm -- completing known symbols and module names
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:22
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Completion interface with emacs.
+
+;;; Code:
+
+(define-module (geiser completion)
+ #:export (completions)
+ #:use-module (geiser utils)
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 regex))
+
+(define (completions prefix . context)
+ (let ((context (and (not (null? context)) (car context)))
+ (prefix (string-append "^" (regexp-quote prefix))))
+ (append (filter (lambda (s) (string-match prefix s))
+ (map symbol->string (local-bindings context)))
+ (sort! (map symbol->string (apropos-internal prefix)) string<?))))
+
+(define (local-bindings form)
+ (define (body f) (if (> (length f) 2) (cddr f) '()))
+ (let loop ((form form) (bindings '()))
+ (cond ((not (pair? form)) bindings)
+ ((list? (car form))
+ (loop (cdr form) (append (local-bindings (car form)) bindings)))
+ ((and (list? form) (< (length form) 2)) bindings)
+ ((memq (car form) '(define define* lambda))
+ (loop (body form) (append (pair->list (cadr form)) bindings)))
+ ((and (memq (car form) '(let let* letrec letrec*))
+ (list? (cadr form)))
+ (loop (body form) (append (map car (cadr form)) bindings)))
+ ((and (eq? 'let (car form)) (symbol? (cadr form)))
+ (loop (cons 'let (body form)) (cons (cadr form) bindings)))
+ (else (loop (cdr form) bindings)))))
+
+;;; completions.scm ends here
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/doc.scm
index 900a5fa..21ede9e 100644
--- a/scheme/guile/geiser/introspection.scm
+++ b/scheme/guile/geiser/doc.scm
@@ -1,4 +1,4 @@
-;; introspection.scm -- name says it all
+;; doc.scm -- name says it all
;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
@@ -20,20 +20,16 @@
;;; Comentary:
-;; Procedures introspecting on scheme objects and their properties.
+;; Procedures providing documentation on scheme objects.
;;; Code:
-(define-module (geiser introspection)
+(define-module (geiser doc)
#:export (autodoc
- completions
- symbol-location
- symbol-documentation
- all-modules
- module-children
- module-location)
+ symbol-documentation)
+ #:use-module (geiser utils)
+ #:use-module (geiser modules)
#:use-module (system vm program)
- #:use-module (ice-9 regex)
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
#:use-module (oop goops)
@@ -55,18 +51,12 @@
(define (describe-application form)
(let* ((fun (car form))
- (args (obj-args (symbol->obj fun))))
+ (args (obj-args (symbol->object fun))))
(and args
(list (cons 'signature (signature fun args))
(cons 'position (find-position args form))
(cons 'module (symbol-module fun))))))
-(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 (arglst args kind)
(let ((args (assq-ref args kind)))
(cond ((or (not args) (null? args)) '())
@@ -105,21 +95,6 @@
(if (null? keys) 0 (+ 1 (length keys)))
(if rest 2 0))))))))
-(define (symbol-module sym)
- (and sym
- (call/cc
- (lambda (k)
- (apropos-fold (lambda (module name var init)
- (if (eq? name sym) (k (module-name module)) init))
- #f
- (regexp-quote (symbol->string sym))
- (apropos-fold-accessible (current-module)))))))
-
-(define (symbol->obj sym)
- (and (symbol? sym)
- (module-defined? (current-module) sym)
- (module-ref (current-module) sym)))
-
(define (obj-args obj)
(cond ((not obj) #f)
((or (procedure? obj) (program? obj)) (arguments obj))
@@ -178,41 +153,11 @@
((not (null? srcs)) (source->args (car (sort! srcs src>))))
(else '((rest . rest))))))
-(define (completions prefix . context)
- (let ((context (and (not (null? context)) (car context)))
- (prefix (string-append "^" (regexp-quote prefix))))
- (append (filter (lambda (s) (string-match prefix s))
- (map symbol->string (local-bindings context)))
- (sort! (map symbol->string (apropos-internal prefix)) string<?))))
-
-(define (local-bindings form)
- (define (body f) (if (> (length f) 2) (cddr f) '()))
- (let loop ((form form) (bindings '()))
- (cond ((not (pair? form)) bindings)
- ((list? (car form))
- (loop (cdr form) (append (local-bindings (car form)) bindings)))
- ((and (list? form) (< (length form) 2)) bindings)
- ((memq (car form) '(define define* lambda))
- (loop (body form) (append (pair->list (cadr form)) bindings)))
- ((and (memq (car form) '(let let* letrec letrec*))
- (list? (cadr form)))
- (loop (body form) (append (map car (cadr form)) bindings)))
- ((and (eq? 'let (car form)) (symbol? (cadr form)))
- (loop (cons 'let (body form)) (cons (cadr form) bindings)))
- (else (loop (cdr form) bindings)))))
-
-(define (module-location name)
- (make-location (module-filename name) #f))
-
-(define (symbol-location sym)
- (cond ((symbol-module sym) => module-location)
- (else '())))
-
-(define (make-location file line)
- (list (cons 'file (if (string? file) file '()))
- (cons 'line (if (number? line) (+ 1 line) '()))))
-
-(define module-filename (@@ (ice-9 session) module-filename))
+(define (symbol-documentation sym)
+ (let ((obj (symbol->object sym)))
+ (if obj
+ `((signature . ,(or (obj-signature sym obj) sym))
+ (docstring . ,(docstring sym obj))))))
(define (docstring sym obj)
(with-output-to-string
@@ -235,64 +180,4 @@
(let ((args (obj-args obj)))
(and args (signature sym args))))
-(define (symbol-documentation sym)
- (let ((obj (symbol->obj sym)))
- (if obj
- `((signature . ,(or (obj-signature sym obj) sym))
- (docstring . ,(docstring sym obj))))))
-
-(define (all-modules)
- (let ((roots ((@@ (ice-9 session) root-modules))))
- (sort! (map (lambda (m)
- (format "~A" (module-name m)))
- (fold (lambda (m all)
- (append (all-child-modules m) all))
- roots
- roots))
- string<?)))
-
-(define (child-modules mod)
- (delq mod ((@@ (ice-9 session) submodules) mod)))
-
-(define (all-child-modules mod)
- (let ((children (child-modules mod)))
- (fold (lambda (m all)
- (append (all-child-modules m) all))
- children children)))
-
-(define (module-children mod-name)
- (let* ((elts (hash-fold classify-module-object
- (list '() '() '())
- (module-obarray (maybe-module-interface mod-name))))
- (elts (map sort-symbols! elts)))
- (list (cons 'modules (map (lambda (m) `(,@mod-name ,m)) (car elts)))
- (cons 'procs (cadr elts))
- (cons 'vars (caddr elts)))))
-
-(define (sort-symbols! syms)
- (let ((cmp (lambda (l r)
- (string<? (symbol->string l) (symbol->string r)))))
- (sort! syms cmp)))
-
-(define (maybe-module-interface mod-name)
- (catch #t
- (lambda () (resolve-interface mod-name))
- (lambda args (resolve-module mod-name))))
-
-(define (classify-module-object name var elts)
- (let ((obj (and (variable-bound? var)
- (variable-ref var))))
- (cond ((not obj) elts)
- ((and (module? obj) (eq? (module-kind obj) 'directory))
- (list (cons name (car elts))
- (cadr elts)
- (caddr elts)))
- ((or (procedure? obj) (program? obj) (macro? obj))
- (list (car elts)
- (cons name (cadr elts))
- (caddr elts)))
- (else (list (car elts)
- (cadr elts)
- (cons name (caddr elts)))))))
-
-;;; introspection.scm ends here
+;;; doc.scm ends here
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index f2f3d45..0c99216 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -25,128 +25,24 @@
;;; Code:
(define-module (geiser emacs)
- #:export (ge:eval
- ge:compile
- ge:macroexpand
- ge:compile-file
- ge:load-file)
- #:re-export (ge:autodoc
+ #:re-export (ge:eval
+ ge:compile
+ ge:macroexpand
+ ge:compile-file
+ ge:load-file
+ ge:autodoc
ge:completions
ge:symbol-location
+ ge:generic-methods
ge:symbol-documentation
ge:all-modules
ge:module-children
ge:module-location)
- #:use-module (srfi srfi-1)
- #:use-module (system base compile)
- #:use-module (system vm program)
- #:use-module (ice-9 debugger utils)
- #:use-module (ice-9 pretty-print)
- #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:)))
+ #: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 (make-result result output)
- (list (cons 'result result) (cons 'output output)))
-
-(define (make-error key args stack)
- (list (cons 'error (apply parse-error (cons key args)))
- (cons 'stack (parse-stack stack))))
-
-(define (parse-stack stack)
- (if stack
- (map (lambda (n) (parse-frame (stack-ref stack n)))
- (iota (stack-length stack)))
- '()))
-
-(define (parse-frame frame)
- (list (cons 'frame (frame-number frame))
- (cons 'procedure (or (and (frame-procedure? frame)
- (procedure-name (frame-procedure frame)))
- '()))
- (cons 'source (or (frame->source-position frame) '()))
- (cons 'description (with-output-to-string
- (lambda ()
- (if (frame-procedure? frame)
- (write-frame-short/application frame)
- (write-frame-short/expression frame)))))))
-
-(define (frame->source-position frame)
- (let ((source (if (frame-procedure? frame)
- (or (frame-source frame)
- (let ((proc (frame-procedure frame)))
- (and proc
- (procedure? proc)
- (procedure-source proc))))
- (frame-source frame))))
- (and source
- (cond ((string? (source-property source 'filename))
- (list (source-property source 'filename)
- (+ 1 (source-property source 'line))
- (source-property source 'column)))
- ((and (pair? source) (list? (cadr source)))
- (list (caadr source)
- (+ 1 (caddr source))
- (cdddr source)))
- (else #f)))))
-
-(define (parse-error key . args)
- (let* ((len (length args))
- (subr (and (> len 0) (first args)))
- (msg (and (> len 1) (second args)))
- (margs (and (> len 2) (third args)))
- (rest (and (> len 3) (fourth args))))
- (list (cons 'key key)
- (cons 'subr (or subr '()))
- (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '()))
- (cons 'rest (or rest '())))))
-
-(define (evaluate form module-name evaluator)
- (let ((module (or (and (list? module-name)
- (resolve-module module-name))
- (current-module)))
- (result #f)
- (captured-stack #f)
- (error #f))
- (let ((output
- (with-output-to-string
- (lambda ()
- (set! result
- (catch #t
- (lambda ()
- (start-stack 'id (evaluator form module)))
- (lambda (key . args)
- (set! error (make-error key args captured-stack)))
- (lambda (key . args)
- (set! captured-stack (make-stack #t 2 2)))))))))
- (write (or error (make-result result output)))
- (newline))))
-
-(define (eval-compile form module)
- (save-module-excursion
- (lambda ()
- (set-current-module module)
- (compile form))))
-
-(define (ge:eval form module-name)
- (evaluate form module-name eval))
-
-(define (ge:compile form module-name)
- (evaluate form module-name eval-compile))
-
-(define (ge:compile-file path)
- "Compile and load file, given its full @var{path}."
- (evaluate `(and (compile-file ,path)
- (load-compiled ,(compiled-file-name path)))
- #f
- eval))
-
-(define (ge:load-file path)
- "Load file, given its full @var{path}."
- (evaluate `(load ,path) #f eval))
-
-(define (ge:macroexpand form . all)
- (let ((all (and (not (null? all)) (car all))))
- (with-output-to-string
- (lambda ()
- (pretty-print ((if all macroexpand macroexpand-1) form))))))
;;; emacs.scm ends here
diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm
new file mode 100644
index 0000000..1f3afc0
--- /dev/null
+++ b/scheme/guile/geiser/evaluation.scm
@@ -0,0 +1,144 @@
+;; evaluation.scm -- evaluation, compilation and macro-expansion
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:46
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Core evaluation engine.
+
+;;; Code:
+
+(define-module (geiser evaluation)
+ #:export (ge:eval
+ ge:compile
+ ge:macroexpand
+ ge:compile-file
+ ge:load-file)
+ #:use-module (srfi srfi-1)
+ #:use-module (system base compile)
+ #:use-module (system vm program)
+ #:use-module (ice-9 debugger utils)
+ #:use-module (ice-9 pretty-print))
+
+(define (make-result result output)
+ (list (cons 'result result) (cons 'output output)))
+
+(define (make-error key args stack)
+ (list (cons 'error (apply parse-error (cons key args)))
+ (cons 'stack (parse-stack stack))))
+
+(define (parse-stack stack)
+ (if stack
+ (map (lambda (n) (parse-frame (stack-ref stack n)))
+ (iota (stack-length stack)))
+ '()))
+
+(define (parse-frame frame)
+ (list (cons 'frame (frame-number frame))
+ (cons 'procedure (or (and (frame-procedure? frame)
+ (procedure-name (frame-procedure frame)))
+ '()))
+ (cons 'source (or (frame->source-position frame) '()))
+ (cons 'description (with-output-to-string
+ (lambda ()
+ (if (frame-procedure? frame)
+ (write-frame-short/application frame)
+ (write-frame-short/expression frame)))))))
+
+(define (frame->source-position frame)
+ (let ((source (if (frame-procedure? frame)
+ (or (frame-source frame)
+ (let ((proc (frame-procedure frame)))
+ (and proc
+ (procedure? proc)
+ (procedure-source proc))))
+ (frame-source frame))))
+ (and source
+ (cond ((string? (source-property source 'filename))
+ (list (source-property source 'filename)
+ (+ 1 (source-property source 'line))
+ (source-property source 'column)))
+ ((and (pair? source) (list? (cadr source)))
+ (list (caadr source)
+ (+ 1 (caddr source))
+ (cdddr source)))
+ (else #f)))))
+
+(define (parse-error key . args)
+ (let* ((len (length args))
+ (subr (and (> len 0) (first args)))
+ (msg (and (> len 1) (second args)))
+ (margs (and (> len 2) (third args)))
+ (rest (and (> len 3) (fourth args))))
+ (list (cons 'key key)
+ (cons 'subr (or subr '()))
+ (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '()))
+ (cons 'rest (or rest '())))))
+
+(define (evaluate form module-name evaluator)
+ (let ((module (or (and (list? module-name)
+ (resolve-module module-name))
+ (current-module)))
+ (result #f)
+ (captured-stack #f)
+ (error #f))
+ (let ((output
+ (with-output-to-string
+ (lambda ()
+ (set! result
+ (catch #t
+ (lambda ()
+ (start-stack 'id (evaluator form module)))
+ (lambda (key . args)
+ (set! error (make-error key args captured-stack)))
+ (lambda (key . args)
+ (set! captured-stack (make-stack #t 2 2)))))))))
+ (write (or error (make-result result output)))
+ (newline))))
+
+(define (eval-compile form module)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module module)
+ (compile form))))
+
+(define (ge:eval form module-name)
+ (evaluate form module-name eval))
+
+(define (ge:compile form module-name)
+ (evaluate form module-name eval-compile))
+
+(define (ge:compile-file path)
+ "Compile and load file, given its full @var{path}."
+ (evaluate `(and (compile-file ,path)
+ (load-compiled ,(compiled-file-name path)))
+ #f
+ eval))
+
+(define (ge:load-file path)
+ "Load file, given its full @var{path}."
+ (evaluate `(load ,path) #f eval))
+
+(define (ge:macroexpand form . all)
+ (let ((all (and (not (null? all)) (car all))))
+ (with-output-to-string
+ (lambda ()
+ (pretty-print ((if all macroexpand macroexpand-1) form))))))
+
+;;; evaluation.scm ends here
diff --git a/scheme/guile/geiser/modules.scm b/scheme/guile/geiser/modules.scm
new file mode 100644
index 0000000..13a1cdd
--- /dev/null
+++ b/scheme/guile/geiser/modules.scm
@@ -0,0 +1,102 @@
+;; modules.scm -- module metadata
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:00
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Utilities for accessing metadata about modules.
+
+;;; Code:
+
+(define-module (geiser modules)
+ #:export (symbol-module
+ module-filename
+ all-modules
+ module-children
+ module-location)
+ #:use-module (geiser utils)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 session)
+ #:use-module (srfi srfi-1))
+
+(define (symbol-module sym)
+ (and sym
+ (call/cc
+ (lambda (k)
+ (apropos-fold (lambda (module name var init)
+ (if (eq? name sym) (k (module-name module)) init))
+ #f
+ (regexp-quote (symbol->string sym))
+ (apropos-fold-accessible (current-module)))))))
+
+(define (module-location name)
+ (make-location (module-filename name) #f))
+
+(define module-filename (@@ (ice-9 session) module-filename))
+
+(define (all-modules)
+ (let ((roots ((@@ (ice-9 session) root-modules))))
+ (sort! (map (lambda (m)
+ (format "~A" (module-name m)))
+ (fold (lambda (m all)
+ (append (all-child-modules m) all))
+ roots
+ roots))
+ string<?)))
+
+(define (module-children mod-name)
+ (let* ((elts (hash-fold classify-module-object
+ (list '() '() '())
+ (module-obarray (maybe-module-interface mod-name))))
+ (elts (map sort-symbols! elts)))
+ (list (cons 'modules (map (lambda (m) `(,@mod-name ,m)) (car elts)))
+ (cons 'procs (cadr elts))
+ (cons 'vars (caddr elts)))))
+
+(define (maybe-module-interface mod-name)
+ (catch #t
+ (lambda () (resolve-interface mod-name))
+ (lambda args (resolve-module mod-name))))
+
+(define (child-modules mod)
+ (delq mod ((@@ (ice-9 session) submodules) mod)))
+
+(define (all-child-modules mod)
+ (let ((children (child-modules mod)))
+ (fold (lambda (m all)
+ (append (all-child-modules m) all))
+ children children)))
+
+(define (classify-module-object name var elts)
+ (let ((obj (and (variable-bound? var)
+ (variable-ref var))))
+ (cond ((not obj) elts)
+ ((and (module? obj) (eq? (module-kind obj) 'directory))
+ (list (cons name (car elts))
+ (cadr elts)
+ (caddr elts)))
+ ((or (procedure? obj) (program? obj) (macro? obj))
+ (list (car elts)
+ (cons name (cadr elts))
+ (caddr elts)))
+ (else (list (car elts)
+ (cadr elts)
+ (cons name (caddr elts)))))))
+
+;;; modules.scm ends here
diff --git a/scheme/guile/geiser/utils.scm b/scheme/guile/geiser/utils.scm
new file mode 100644
index 0000000..1aa919a
--- /dev/null
+++ b/scheme/guile/geiser/utils.scm
@@ -0,0 +1,53 @@
+;; utils.scm -- utility functions
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 01:48
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Some utilities used by other modules.
+
+;;; Code:
+
+(define-module (geiser utils)
+ #:export (make-location
+ symbol->object
+ pair->list
+ sort-symbols!))
+
+(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)))
+
+;;; utils.scm ends here
diff --git a/scheme/guile/geiser/xref.scm b/scheme/guile/geiser/xref.scm
new file mode 100644
index 0000000..2cd4d80
--- /dev/null
+++ b/scheme/guile/geiser/xref.scm
@@ -0,0 +1,37 @@
+;; xref.scm -- cross-referencing utilities
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:37
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Procedures to locate symbols and their xrefs.
+
+;;; Code:
+
+(define-module (geiser xref)
+ #:export (symbol-location
+ generic-methods)
+ #:use-module (geiser utils)
+ #:use-module (geiser modules))
+
+(define (symbol-location sym)
+ (cond ((symbol-module sym) => module-location)
+ (else '())))
+
+;;; xref.scm ends here