Support for multiple Scheme implementations, Chapter 1.

  * Evaluation system is now pluggable
  * The rest of the system understands said pluggability
  * Guile provides its own implementation (geiser-guile)
  * The reload system is aware of the new kids on the block

9 files changed, 285 insertions, 61 deletions

diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el
index e2569eb..d2991b2 100644
--- a/elisp/geiser-completion.el
+++ b/elisp/geiser-completion.el
@@ -181,11 +181,13 @@ terminates a current completion."
 
 (defun geiser-completion--read-module (&optional prompt default history)
   (let ((minibuffer-local-completion-map geiser-completion--module-minibuffer-map))
-    (completing-read (or prompt "Module name: ")
-                     (geiser-completion--module-list)
-                     nil nil
-                     (or default (format "%s" (or (geiser-syntax--buffer-module) "(")))
-                     (or history geiser-completion--module-history))))
+    (geiser-eval--get-module
+     (completing-read (or prompt "Module name: ")
+                      (geiser-completion--module-list)
+                      nil nil
+                      (or default
+                          (format "%s" (or (geiser-syntax--buffer-module) "(")))
+                      (or history geiser-completion--module-history)))))
 
 (defun geiser--respecting-message (format &rest format-args)
   "Display TEXT as a message, without hiding any minibuffer contents."
diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el
index 6d2eb40..af1e402 100644
--- a/elisp/geiser-doc.el
+++ b/elisp/geiser-doc.el
@@ -60,7 +60,7 @@
   (car geiser-doc--history))
 
 (defun geiser-doc--history-push (link)
-  (unless (equal link (car geiser-doc--history))
+  (unless (or (null link) (equal link (car geiser-doc--history)))
     (let ((next (geiser-doc--history-next)))
       (unless (equal link next)
         (when next (geiser-doc--history-previous))
@@ -80,13 +80,14 @@
       (ring-insert (nth 2 geiser-doc--history) (car geiser-doc--history)))
     (setcar geiser-doc--history (ring-remove (nth 1 geiser-doc--history) 0))))
 
-(defvar geiser-doc--history (geiser-doc--make-history))
+(defvar geiser-doc--history nil)
+(setq geiser-doc--history (geiser-doc--make-history))
 
 
 ;;; Links
 
-(defsubst geiser-doc--make-link (target module)
-  (list target module))
+(defsubst geiser-doc--make-link (target module impl)
+  (list target module impl))
 
 (defsubst geiser-doc--link-target (link)
   (nth 0 link))
@@ -94,13 +95,19 @@
 (defsubst geiser-doc--link-module (link)
   (nth 1 link))
 
+(defsubst geiser-doc--link-impl (link)
+  (nth 2 link))
+
 (defun geiser-doc--follow-link (link)
   (let ((target (geiser-doc--link-target link))
-        (module (geiser-doc--link-module link)))
-    (when target
-      (if (symbolp target)
-          (geiser-doc-symbol target module)
-        (geiser-doc-module (format "%s" target))))))
+        (module (geiser-doc--link-module link))
+        (impl (or (geiser-doc--link-impl link)
+                  (geiser-impl--default-implementation))))
+    (when (and (or target module) impl)
+      (with--geiser-implementation impl
+        `(lambda () (if (null ',target)
+                   (geiser-doc-module ',module ',impl)
+                 (geiser-doc-symbol ',target ',module ',impl)))))))
 
 (defun geiser-doc--button-action (button)
   (let ((link (button-get button 'geiser-link)))
@@ -111,8 +118,8 @@
   'face 'geiser-font-lock-doc-link
   'follow-link t)
 
-(defun geiser-doc--insert-button (target module)
-  (let ((link (geiser-doc--make-link target module))
+(defun geiser-doc--insert-button (target module impl)
+  (let ((link (geiser-doc--make-link target module impl))
         (text (format "%s" target))
         (help (if module (format "%s in module %s" target module) "")))
     (insert-text-button text
@@ -134,13 +141,13 @@
     (put-text-property p (point) 'face 'geiser-font-lock-doc-title)
     (newline)))
 
-(defun geiser-doc--insert-list (title lst module)
+(defun geiser-doc--insert-list (title lst module impl)
   (when lst
     (geiser-doc--insert-title title)
     (newline)
     (dolist (w lst)
       (insert (format "\t- "))
-      (geiser-doc--insert-button w module)
+      (geiser-doc--insert-button w module impl)
       (newline))
     (newline)))
 
@@ -154,11 +161,11 @@
   (geiser-eval--send/result `(:eval ((:ge symbol-documentation) ',symbol) ,module)))
 
 (defun geiser-doc--get-module-children (module)
-  (geiser-eval--send/result `(:eval ((:ge module-children) (quote (:scm ,module))))))
+  (geiser-eval--send/result `(:eval ((:ge module-children) (:module ,module)))))
 
-(defun geiser-doc-symbol (symbol &optional module)
-  (let* ((module (or module
-                     (geiser-syntax--buffer-module)))
+(defun geiser-doc-symbol (symbol &optional module impl)
+  (let* ((module (or module (geiser-eval--get-module)))
+         (impl (or impl geiser-impl--implementation))
          (ds (geiser-doc--get-docstring symbol module)))
     (if (or (not ds) (not (listp ds)))
         (message "No documentation available for '%s'" symbol)
@@ -167,9 +174,10 @@
        (geiser-doc--insert-title (cdr (assoc 'signature ds)))
        (newline)
        (insert (or (cdr (assoc 'docstring ds)) ""))
-       (goto-line (point-min)))
-      (setq geiser-doc--buffer-link
-            (geiser-doc--history-push (geiser-doc--make-link symbol module)))
+       (goto-line (point-min))
+       (setq geiser-doc--buffer-link
+             (geiser-doc--history-push
+              (geiser-doc--make-link symbol module impl))))
       (geiser-doc--pop-to-buffer))))
 
 (defun geiser-doc-symbol-at-point (&optional arg)
@@ -181,11 +189,11 @@ With prefix argument, ask for symbol (with completion)."
     (when symbol (geiser-doc-symbol symbol))))
 
 
-(defun geiser-doc-module (module)
+(defun geiser-doc-module (module &optional impl)
   "Display information about a given module."
   (interactive (list (geiser-completion--read-module)))
   (let ((children (geiser-doc--get-module-children module))
-        (mod-sym (car (read-from-string module))))
+        (impl (or impl geiser-impl--implementation)))
     (if (not children)
         (message "No info available for %s" module)
       (geiser-doc--with-buffer
@@ -194,17 +202,19 @@ With prefix argument, ask for symbol (with completion)."
         (newline)
         (geiser-doc--insert-list "Procedures:"
                                  (cdr (assoc 'procs children))
-                                 mod-sym)
+                                 module
+                                 impl)
         (geiser-doc--insert-list "Variables:"
                                  (cdr (assoc 'vars children))
-                                 mod-sym)
+                                 module
+                                 impl)
         (geiser-doc--insert-list "Submodules:"
                                  (cdr (assoc 'modules children))
-                                 mod-sym)
-        (goto-char (point-min)))
-      (setq geiser-doc--buffer-link
-            (geiser-doc--history-push (geiser-doc--make-link (car (read-from-string module))
-                                                             nil)))
+                                 module
+                                 impl)
+        (goto-char (point-min))
+        (setq geiser-doc--buffer-link
+              (geiser-doc--history-push (geiser-doc--make-link nil module impl))))
       (geiser-doc--pop-to-buffer))))
 
 (defun geiser-doc-next (&optional forget-current)
@@ -279,6 +289,7 @@ With prefix, the current page is deleted from history."
 
 (geiser-popup--define doc "*Geiser documentation*" geiser-doc-mode)
 
+
 
 (provide 'geiser-doc)
 ;;; geiser-doc.el ends here
diff --git a/elisp/geiser-edit.el b/elisp/geiser-edit.el
index e5c30eb..6938b60 100644
--- a/elisp/geiser-edit.el
+++ b/elisp/geiser-edit.el
@@ -127,7 +127,7 @@ With prefix, asks for the symbol to edit."
 (defun geiser-edit-module (module)
   "Asks for a module and opens it in a new buffer."
   (interactive (list (geiser-completion--read-module)))
-  (let ((cmd `(:eval ((:ge module-location) (quote (:scm ,module))))))
+  (let ((cmd `(:eval ((:ge module-location) ,module))))
     (geiser-edit--try-edit module (geiser-eval--send/wait cmd))))
 
 
diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el
index 3e5e7aa..8574cdc 100644
--- a/elisp/geiser-eval.el
+++ b/elisp/geiser-eval.el
@@ -34,14 +34,22 @@
 ;;; Plug-able functions:
 
 (make-variable-buffer-local
- (defvar geiser-eval--current-module-function 'geiser-syntax--buffer-module))
+ (defvar geiser-eval--get-module-function 'geiser-syntax--buffer-module
+   "Function used to obtain the module for current buffer. It
+takes an optional argument, for cases where we want to force its value."))
 
-(defsubst geiser-eval--current-module-function (fun)
-  (setq geiser-eval--current-module-function fun))
+(defsubst geiser-eval--get-module (&optional module)
+  (and geiser-eval--get-module-function
+       (funcall geiser-eval--get-module-function module)))
 
-(defsubst geiser-eval--current-module ()
-  (and geiser-eval--current-module-function
-       (funcall geiser-eval--current-module-function)))
+(make-variable-buffer-local
+ (defvar geiser-eval--geiser-procedure-function nil
+   "Translate a bare procedure symbol to one executable in Guile's
+context. Return NULL for unsupported ones; at the very least,
+EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported."))
+
+(defsubst geiser-eval--form (proc)
+  (funcall geiser-eval--geiser-procedure-function proc))
 
 
 ;;; Code formatting:
@@ -64,28 +72,27 @@
 
 (defsubst geiser-eval--eval (code)
   (geiser-eval--scheme-str
-   `((@ (geiser emacs) ge:eval) (quote ,(nth 0 code)) (:module ,(nth 1 code)))))
+   `(,(geiser-eval--form 'eval) (quote ,(nth 0 code)) (:module ,(nth 1 code)))))
 
 (defsubst geiser-eval--comp (code)
   (geiser-eval--scheme-str
-   `((@ (geiser emacs) ge:compile) (quote ,(nth 0 code)) (:module ,(nth 1 code)))))
+   `(,(geiser-eval--form 'compile (quote ,(nth 0 code)) (:module ,(nth 1 code))))))
 
 (defsubst geiser-eval--load-file (file)
-  (geiser-eval--scheme-str `((@ (geiser emacs) ge:load-file) ,file)))
+  (geiser-eval--scheme-str `(,(geiser-eval--form 'load-file) ,file)))
 
 (defsubst geiser-eval--comp-file (file)
-  (geiser-eval--scheme-str `((@ (geiser emacs) ge:compile-file) ,file)))
+  (geiser-eval--scheme-str `(,(geiser-eval--form 'compile-file) ,file)))
 
 (defsubst geiser-eval--module (code)
   (geiser-eval--scheme-str
-   (cond ((or (eq code '(())) (null code))
-          `(quote ,(or (geiser-eval--current-module) :f)))
-         ((listp code) `(quote ,code))
-         ((stringp code) (:scm code))
-         (t (error "Invalid module spec: %S" code)))))
+   (cond ((or (null code) (eq code :t) (eq code :buffer))
+          (list 'quote (funcall geiser-eval--get-module-function)))
+         ((or (eq code :repl) (eq code :f)) :f)
+         (t (list 'quote (funcall geiser-eval--get-module-function code))))))
 
 (defsubst geiser-eval--ge (proc)
-  (format "(@ (geiser emacs) ge:%s)" proc))
+  (geiser-eval--scheme-str (geiser-eval--form proc)))
 
 
 ;;; Code sending:
diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el
new file mode 100644
index 0000000..741002a
--- /dev/null
+++ b/elisp/geiser-impl.el
@@ -0,0 +1,176 @@
+;; geiser-impl.el -- generic support for scheme implementations
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sat Mar 07, 2009 23:32
+
+;; 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:
+
+;; Functions to handle setup of Scheme implementations supported by
+;; Geiser.
+
+;;; Code:
+
+(require 'geiser-eval)
+(require 'geiser-base)
+
+
+;;; Customization:
+
+(defgroup geiser-impl nil
+  "Generic support for multiple Scheme implementations."
+  :group 'geiser)
+
+(defcustom geiser-impl-default-implementation 'guile
+  "Symbol naming the default Scheme implementation."
+  :type 'symbol
+  :group 'geiser-impl)
+
+
+;;; Registering implementations:
+
+(defvar geiser-impl--impls nil)
+
+(defun geiser-impl--register (impl)
+  (add-to-list 'geiser-impl--impls impl))
+
+(defun geiser-impl--unregister (impl)
+  (remove impl geiser-impl--impls))
+
+(defvar geiser-impl--default-implementation
+  geiser-impl-default-implementation)
+
+(defun geiser-impl--default-implementation (&optional new)
+  (when new (setq geiser-impl--default-implementation new))
+  (or geiser-impl--default-implementation
+      geiser-impl-default-implementation
+      (car geiser-impl--impls)))
+
+
+;;; Installing Scheme implementations:
+
+(make-local-variable
+ (defvar geiser-impl--implementation nil))
+
+(defsubst geiser-impl--impl-feature (impl)
+  (intern (format "geiser-%s" impl)))
+
+(defun geiser-impl--set-buffer-implementation (&optional impl)
+  (let ((impl (or impl
+                  (geiser-impl--guess)
+                  (intern (read-string "Scheme implementation: ")))))
+    (require (geiser-impl--impl-feature impl))
+    (setq geiser-impl--implementation impl)
+    (geiser-impl--install-eval impl)
+    (geiser-impl--register impl)))
+
+
+(defsubst geiser-impl--sym (imp name)
+  (intern (format "geiser-%s-%s" imp name)))
+
+(defsubst geiser-impl--boundp (imp name)
+  (boundp (geiser-impl--sym imp name)))
+
+(defsubst geiser-impl--fboundp (imp name)
+  (fboundp (geiser-impl--sym imp name)))
+
+(defun geiser-impl--value (imp name &optional fun)
+  (let ((sym (geiser-impl--sym imp name)))
+    (unless (or (and (not fun) (boundp sym))
+                (and fun (fboundp sym)))
+      (error "Unbound %s '%s' in Geiser Scheme implementation %s"
+             (if fun "function" "variable") sym imp))
+    (if fun (symbol-function sym) (symbol-value sym))))
+
+(defsubst geiser-impl--call-if-bound (imp name &rest args)
+  (when (geiser-impl--fboundp imp name)
+    (apply (geiser-impl--value imp name t) args)))
+
+(defun geiser-impl--install-eval (imp)
+  (setq geiser-eval--get-module-function
+        (geiser-impl--sym imp "get-module")
+        geiser-eval--geiser-procedure-function
+        (geiser-impl--sym imp "geiser-procedure")))
+
+
+;;; Evaluating Elisp in a given implementation context:
+
+(defun with--geiser-implementation (imp thunk)
+  (let ((geiser-impl--implementation imp)
+        (geiser-eval--get-module-function
+         (geiser-impl--sym imp "get-module"))
+        (geiser-eval--geiser-procedure-function
+         (geiser-impl--sym imp "geiser-procedure")))
+    (funcall thunk)))
+
+(put 'with--geiser-implementation 'lisp-indent-function 1)
+
+
+;;; Default evaluation environment:
+
+(defun geiser-impl-module (&optional module)
+  (geiser-impl--call-if-bound (geiser-impl--default-implementation)
+                              "get-module"
+                              module))
+(set-default 'geiser-eval--get-module-function 'geiser-impl-module)
+
+(defun geiser-impl-geiser-procedure (proc)
+  (geiser-impl--call-if-bound (geiser-impl--default-implementation)
+                              "geiser-procedure"
+                              proc))
+(set-default 'geiser-eval--geiser-procedure-function 'geiser-impl-geiser-procedure)
+
+
+;;; Access to implementation specific execution parameters:
+
+(defsubst geiser-impl--binary (impl)
+  (or (geiser-impl--call-if-bound impl "binary")
+      (geiser-impl--value imp "binary")))
+
+(defsubst geiser-impl--parameters (impl)
+  (or (geiser-impl--call-if-bound impl "parameters")
+      (ignore-errors (geiser-impl--value imp "parameters"))))
+
+(defsubst geiser-impl--prompt-regexp (impl)
+  (or (geiser-impl--call-if-bound impl "prompt-regexp")
+      (geiser-impl--value imp "prompt-regexp")))
+
+
+;;; Access to implementation guessing function:
+
+(defun geiser-impl--guess ()
+  (catch 'impl
+    (dolist (impl geiser-impl--impls)
+      (when (geiser-impl--call-if-bound impl "guess")
+        (throw 'impl impl)))
+    (geiser-impl--default-implementation)))
+
+
+;;; Unload support
+
+(defun geiser-impl-unload-function ()
+  (dolist (imp (mapcar 'geiser-impl--impl-feature geiser-impl--impls))
+    (when (featurep imp) (unload-feature imp)))
+  t)
+
+(defun geiser-impl--reload-implementations (impls)
+  (dolist (impl impls)
+    (load-library (format "geiser-%s" impl))))
+
+
+(provide 'geiser-impl)
+;;; geiser-impl.el ends here
diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el
index 4bb2dcf..640a7e9 100644
--- a/elisp/geiser-mode.el
+++ b/elisp/geiser-mode.el
@@ -31,6 +31,7 @@
 (require 'geiser-edit)
 (require 'geiser-autodoc)
 (require 'geiser-debug)
+(require 'geiser-impl)
 (require 'geiser-eval)
 (require 'geiser-repl)
 (require 'geiser-popup)
@@ -153,6 +154,7 @@ interacting with the Geiser REPL is at your disposal.
   :lighter geiser-mode-string
   :group 'geiser-mode
   :keymap geiser-mode-map
+  (when geiser-mode (geiser-impl--set-buffer-implementation))
   (setq geiser-autodoc-mode-string "/A")
   (setq geiser-smart-tab-mode-string "/T")
   (when geiser-mode-autodoc-p (geiser-autodoc-mode geiser-mode))
@@ -212,9 +214,17 @@ interacting with the Geiser REPL is at your disposal.
     (dolist (buffer (buffer-list))
       (when (buffer-live-p buffer)
         (set-buffer buffer)
-        (when geiser-mode (push buffer buffers))))
+        (when geiser-mode
+          (push (cons buffer geiser-impl--implementation) buffers))))
     buffers))
 
+(defun geiser-mode--restore (buffers)
+  (dolist (b buffers)
+    (when (buffer-live-p (car b))
+      (set-buffer (car b))
+      (geiser-mode 1)
+      (when (cdr b) (geiser-impl--set-buffer-implementation (cdr b))))))
+
 
 (provide 'geiser-mode)
 ;;; geiser-mode.el ends here
diff --git a/elisp/geiser-popup.el b/elisp/geiser-popup.el
index d412029..486d1d8 100644
--- a/elisp/geiser-popup.el
+++ b/elisp/geiser-popup.el
@@ -58,12 +58,18 @@
   '(("q" . geiser-popup--quit))
   (setq buffer-read-only t))
 
+
+;;; Support for defining popup buffers and accessors:
+
+(defvar geiser-popup--registry nil)
+
 (defmacro geiser-popup--define (base name mode)
   (let ((get-buff (intern (format "geiser-%s--buffer" base)))
         (pop-buff (intern (format "geiser-%s--pop-to-buffer" base)))
         (with-macro (intern (format "geiser-%s--with-buffer" base)))
         (method (make-symbol "method")))
   `(progn
+     (add-to-list 'geiser-popup--registry ,name)
      (defun ,get-buff ()
        (or (get-buffer ,name)
            (with-current-buffer (get-buffer-create ,name)
@@ -84,5 +90,13 @@
 (put 'geiser-popup--define 'lisp-indent-function 1)
 
 
+;;; Reload support:
+
+(defun geiser-popup-unload-function ()
+  (dolist (name geiser-popup--registry)
+    (when (buffer-live-p (get-buffer name))
+      (kill-buffer name))))
+
+
 (provide 'geiser-popup)
 ;;; geiser-popup.el ends here
diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el
index a5f424b..7232b99 100644
--- a/elisp/geiser-repl.el
+++ b/elisp/geiser-repl.el
@@ -26,6 +26,7 @@
 
 (require 'geiser-autodoc)
 (require 'geiser-edit)
+(require 'geiser-impl)
 (require 'geiser-eval)
 (require 'geiser-connection)
 (require 'geiser-custom)
@@ -193,6 +194,8 @@ REPL buffer."
     (when (not (eq (char-after (point)) ?\())
       (skip-syntax-forward "^(" p))))
 
+(defun geiser-repl--module-function (&optional ignore) :f)
+
 (define-derived-mode geiser-repl-mode comint-mode "Geiser REPL"
   "Major mode for interacting with an inferior Guile repl process.
 \\{geiser-repl-mode-map}"
@@ -203,7 +206,9 @@ REPL buffer."
   (set (make-local-variable 'beginning-of-defun-function)
        'geiser-repl--beginning-of-defun)
   (set-syntax-table scheme-mode-syntax-table)
-  (geiser-eval--current-module-function nil)
+  ;;; TODO: fix this call when we add support to multiple implementations
+  (geiser-impl--set-buffer-implementation)
+  (setq geiser-eval--get-module-function 'geiser-repl--module-function)
   (when geiser-repl-autodoc-p (geiser-autodoc-mode 1)))
 
 (define-key geiser-repl-mode-map "\C-cz" 'run-guile)
diff --git a/elisp/geiser.el b/elisp/geiser.el
index 7415390..f827864 100644
--- a/elisp/geiser.el
+++ b/elisp/geiser.el
@@ -92,6 +92,7 @@
            geiser-autodoc
            geiser-compile
            geiser-debug
+           geiser-impl
            geiser-eval
            geiser-connection
            geiser-syntax
@@ -122,6 +123,7 @@ loaded."
                                                 geiser-root-dir))
                   geiser-root-dir))
          (geiser-main-file (expand-file-name "elisp/geiser.el" dir))
+         (impls (and (featurep 'geiser-impl) geiser-impl--impls))
          (repl (and (featurep 'geiser-repl) (geiser-repl--live-p)))
          (buffers (and (featurep 'geiser-mode) (geiser-mode--buffers))))
     (unless (file-exists-p geiser-main-file)
@@ -130,14 +132,11 @@ loaded."
     (geiser-unload)
     (load-file geiser-main-file)
     (geiser-setup)
-    (when repl
-      (load-library "geiser-repl")
-      (geiser 'repl))
-    (when buffers
-      (load-library "geiser-mode")
-      (dolist (b buffers)
-        (set-buffer b)
-        (geiser-mode 1)))
+    (dolist (feature (geiser--features-list))
+      (load-library (format "%s" feature)))
+    (when impls (geiser-impl--reload-implementations impls))
+    (when repl (geiser 'repl))
+    (when buffers (geiser-mode--restore buffers))
     (message "Geiser reloaded!")))