summaryrefslogtreecommitdiff
path: root/elisp/geiser-impl.el
diff options
context:
space:
mode:
Diffstat (limited to 'elisp/geiser-impl.el')
-rw-r--r--elisp/geiser-impl.el176
1 files changed, 176 insertions, 0 deletions
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