PLT: Evaluation takes into account #lang forms.

This is useful when visiting a file that has not been loaded: the
evaluation namespace is provided by its #lang, if any.

While i was at it, i also refactored the mess in geiser:load-file.

4 files changed, 46 insertions, 31 deletions

diff --git a/elisp/geiser-plt.el b/elisp/geiser-plt.el
index 1352e2f..01e10a2 100644
--- a/elisp/geiser-plt.el
+++ b/elisp/geiser-plt.el
@@ -62,14 +62,22 @@ This function uses `geiser-plt-init-file' if it exists."
       ,@(and init-file (file-readable-p init-file) (list "-f" init-file))
       "-f" ,(expand-file-name "plt/geiser.ss" geiser-scheme-dir))))
 
-(defconst geiser-plt--prompt-regexp "^mzscheme@[^ ]*?> ")
+(defconst geiser-plt--prompt-regexp "^=?mzscheme@[^ ]*?> ")
 
 
 ;;; Evaluation support:
 
+(defun geiser-plt--language ()
+  (save-excursion
+    (goto-char (point-min))
+    (if (re-search-forward "^#lang +\\([^ ]+?\\) *$" nil t)
+        (intern (match-string-no-properties 1))
+      :f)))
+
 (defun geiser-plt--geiser-procedure (proc)
-  (let ((proc (intern (format "geiser:%s" proc))))
-    `(dynamic-require ''geiser ',proc)))
+  (if (memq proc '(eval compile))
+      `((dynamic-require ''geiser 'geiser:eval) ',(geiser-plt--language))
+    `(dynamic-require ''geiser ',(intern (format "geiser:%s" proc)))))
 
 (defconst geiser-plt--module-re
   "^(module +\\([^ ]+\\)")
@@ -89,7 +97,8 @@ This function uses `geiser-plt-init-file' if it exists."
       :f)))
 
 (defun geiser-plt--get-module (&optional module)
-  (cond ((and (null module) (buffer-file-name))) ;; (geiser-plt--explicit-module)
+  (cond ((and (null module) (buffer-file-name)))
+        ;; (geiser-plt--explicit-module)
         ((null module) (geiser-plt--implicit-module))
         ((symbolp module) module)
         ((and (stringp module) (file-name-absolute-p module)) module)
diff --git a/scheme/plt/geiser.ss b/scheme/plt/geiser.ss
index c46f06c..a86b6a9 100644
--- a/scheme/plt/geiser.ss
+++ b/scheme/plt/geiser.ss
@@ -38,7 +38,8 @@
            geiser/locations
            geiser/autodoc)
 
-  (define geiser:eval eval-in)
+  (define (geiser:eval lang)
+    (lambda (form spec) (eval-in form spec lang)))
   (define geiser:compile compile-in)
   (define geiser:load-file load-file)
   (define geiser:compile-file compile-file)
diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss
index 86b10cd..d432daa 100644
--- a/scheme/plt/geiser/eval.ss
+++ b/scheme/plt/geiser/eval.ss
@@ -41,27 +41,28 @@
 (define (set-last-result . vs)
   (set! last-result `((result  ,@(map write-value vs)))))
 
-(define (eval-in form spec)
+(define (call-with-result thunk)
   (set-last-result (void))
   (let ((output
          (with-output-to-string
            (lambda ()
              (with-handlers ((exn? set-last-error))
-               (update-module-cache spec form)
-               (call-with-values
-                   (lambda () (eval form (module-spec->namespace spec)))
-                 set-last-result))))))
+               (call-with-values thunk set-last-result))))))
     (append last-result `((output . ,output)))))
 
+(define (eval-in form spec lang)
+  (call-with-result
+   (lambda ()
+     (update-module-cache spec form)
+     (eval form (module-spec->namespace spec lang)))))
+
 (define compile-in eval-in)
 
 (define (load-file file)
-  (let ((current-path (namespace->module-path-name (last-namespace)))
-        (result (eval-in `(load-module ,file (current-output-port))
-                         'geiser/eval)))
-    (update-module-cache file)
-    (load-module (and (path? current-path) (path->string current-path)))
-    result))
+  (call-with-result
+   (lambda ()
+     (load-module file (current-output-port) (last-namespace))
+     (update-module-cache file))))
 
 (define compile-file load-file)
 
diff --git a/scheme/plt/geiser/modules.ss b/scheme/plt/geiser/modules.ss
index 3dea0c3..3d6314d 100644
--- a/scheme/plt/geiser/modules.ss
+++ b/scheme/plt/geiser/modules.ss
@@ -24,30 +24,32 @@
 (define (ensure-module-spec spec)
   (cond ((symbol? spec) spec)
         ((not (string? spec)) #f)
-        ((not (file-exists? spec)) #f)
-        ((absolute-path? spec) `(file ,spec))
-        (else spec)))
+        (else `(file ,spec))))
 
-(define (module-spec->namespace spec)
+(define (module-spec->namespace spec lang)
   (let* ((spec (ensure-module-spec spec))
-         (contract-handler (lambda (e)
-                             (load-module spec)
-                             (enter! #f)
-                             (module->namespace spec)))
+         (try-lang (lambda (e)
+                     (if (symbol? lang)
+                         (begin
+                           (load-module lang #f (current-namespace))
+                           (module->namespace lang))
+                         (current-namespace))))
          (filesystem-handler (lambda (e)
-                               (when (symbol? spec)
+                               (with-handlers ((exn? try-lang))
                                  (module->namespace `',spec)))))
     (if spec
-        (with-handlers ((exn:fail:contract? contract-handler)
-                        (exn:fail:filesystem? filesystem-handler))
+        (with-handlers ((exn:fail:filesystem? filesystem-handler)
+                        (exn? try-lang))
           (module->namespace spec))
         (current-namespace))))
 
 (define nowhere (open-output-nowhere))
 
-(define (load-module spec . port)
-  (parameterize ((current-error-port (if (null? port) nowhere (car port))))
-    (eval #`(enter! #,(ensure-module-spec spec)))))
+(define (load-module spec (port #f) (ns #f))
+  (parameterize ((current-error-port (or port nowhere)))
+    (eval #`(enter! #,(ensure-module-spec spec)))
+    (when (namespace? ns)
+      (current-namespace ns))))
 
 (define (namespace->module-path-name ns)
   (let ((rmp (variable-reference->resolved-module-path
@@ -67,7 +69,9 @@
                              (current-library-collection-paths)))
                 (prefix-len (lambda (p)
                               (let ((pl (string-length p)))
-                                (if (= pl (string-prefix-length p path)) pl 0))))
+                                (if (= pl (string-prefix-length p path))
+                                    pl
+                                    0))))
                 (lens (map prefix-len cpaths))
                 (real-path (substring path (apply max lens))))
            (if (absolute-path? real-path)