From 3b6e0b859262970b43672ed7c9207187b2518976 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Mon, 9 Mar 2009 23:52:04 +0100
Subject: 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
---
elisp/geiser-completion.el | 12 ++--
elisp/geiser-doc.el | 69 ++++++++++--------
elisp/geiser-edit.el | 2 +-
elisp/geiser-eval.el | 39 +++++-----
elisp/geiser-impl.el | 176 +++++++++++++++++++++++++++++++++++++++++++++
elisp/geiser-mode.el | 12 +++-
elisp/geiser-popup.el | 14 ++++
elisp/geiser-repl.el | 7 +-
elisp/geiser.el | 15 ++--
9 files changed, 285 insertions(+), 61 deletions(-)
create mode 100644 elisp/geiser-impl.el
(limited to 'elisp')
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)
@@ -83,6 +89,14 @@
(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!")))
--
cgit v1.2.3