From 17b23aa1bfe807c68ddc5ff01eaccc99fd02a058 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Mon, 7 Jun 2010 01:25:14 +0200
Subject: Guile: real fix for symbol locations (needs Guile's git head).

---
 scheme/guile/geiser/evaluation.scm |  8 +-------
 scheme/guile/geiser/modules.scm    | 23 ++++++++++++++++++++---
 scheme/guile/geiser/xref.scm       |  2 +-
 3 files changed, 22 insertions(+), 11 deletions(-)

(limited to 'scheme')

diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm
index 179e425..a0007c4 100644
--- a/scheme/guile/geiser/evaluation.scm
+++ b/scheme/guile/geiser/evaluation.scm
@@ -15,6 +15,7 @@
             ge:macroexpand
             ge:compile-file
             ge:load-file)
+  #:use-module (geiser modules)
   #:use-module (srfi srfi-1)
   #:use-module (language tree-il)
   #:use-module (system base compile)
@@ -33,13 +34,6 @@
     (else (display (format "ERROR: ~a, args: ~a" (car args) (cdr args)))))
   `(error (key . ,(car args))))
 
-(define (find-module module-name)
-  (and (list? module-name)
-       (or (nested-ref the-root-module (append '(%app modules) module-name))
-           (let ((m (resolve-module module-name)))
-             (beautify-user-module! m)
-             m))))
-
 (define (write-result result output)
   (write (list (cons 'result result) (cons 'output output)))
   (newline))
diff --git a/scheme/guile/geiser/modules.scm b/scheme/guile/geiser/modules.scm
index 2934603..39b01b8 100644
--- a/scheme/guile/geiser/modules.scm
+++ b/scheme/guile/geiser/modules.scm
@@ -11,7 +11,9 @@
 
 (define-module (geiser modules)
   #:export (symbol-module
-            module-filename
+            module-name?
+            module-path
+            find-module
             all-modules
             module-exports
             module-location)
@@ -21,6 +23,11 @@
   #:use-module (ice-9 session)
   #:use-module (srfi srfi-1))
 
+(define (module-name? module-name)
+  (and (list? module-name)
+       (> (length module-name) 0)
+       (every symbol? module-name)))
+
 (define (symbol-module sym . all)
   (and sym
        (catch 'module-name
@@ -38,9 +45,19 @@
            (and (eq? key 'module-name) (car args))))))
 
 (define (module-location name)
-  (make-location (module-filename name) #f))
+  (make-location (module-path name) #f))
+
+(define (find-module module-name)
+  (and (module-name? module-name)
+       (or (nested-ref (resolve-module '() #f) module-name)
+           (let ((m (resolve-module module-name)))
+             (beautify-user-module! m)
+             m))))
 
-(define module-filename (@@ (ice-9 session) module-filename))
+(define (module-path module-name)
+  (and (module-name? module-name)
+       (or ((@@ (ice-9 session) module-filename) module-name)
+           (module-filename (resolve-module module-name)))))
 
 (define (all-modules)
   (let ((roots ((@@ (ice-9 session) root-modules))))
diff --git a/scheme/guile/geiser/xref.scm b/scheme/guile/geiser/xref.scm
index 060bec4..18005ee 100644
--- a/scheme/guile/geiser/xref.scm
+++ b/scheme/guile/geiser/xref.scm
@@ -55,7 +55,7 @@
 (define (program-path p)
   (let* ((mod (program-module p))
          (name (and mod (module-name mod))))
-    (and name (module-filename name))))
+    (and name (module-path name))))
 
 (define (procedure-xref proc . mod-name)
   (let ((proc-name (or (procedure-name proc) '<anonymous>))
-- 
cgit v1.2.3