diff options
Diffstat (limited to 'elisp/geiser-impl.el')
| -rw-r--r-- | elisp/geiser-impl.el | 138 |
1 files changed, 99 insertions, 39 deletions
diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el index 6bc4e79..00fa1ef 100644 --- a/elisp/geiser-impl.el +++ b/elisp/geiser-impl.el @@ -27,7 +27,6 @@ (require 'geiser-eval) (require 'geiser-base) -(require 'geiser-doc) (require 'geiser-completion) @@ -47,16 +46,63 @@ :type '(repeat symbol) :group 'geiser-impl) +(defcustom geiser-impl-implementations-alist nil + "A map from regular expressions or directories to implementations. +When opening a new file, its full path will be matched against +each one of the regular expressions or directories in this map in order to +determine its scheme flavour." + :type '(repeat (list (choice (group :tag "Regular expression" + (const regexp) regexp) + (group :tag "Directory" + (const dir) directory)) + symbol)) + :group 'geiser-impl) + + +;;; Auxiliary functions: +(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))) + +(defsubst geiser-impl--impl-feature (impl) + (intern (format "geiser-%s" impl))) + +(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))) + ;;; Registering implementations: (defvar geiser-impl--impls nil) +(make-variable-buffer-local + (defvar geiser-impl--implementation nil)) + (defun geiser-impl--register (impl) - (add-to-list 'geiser-impl--impls impl)) + (when (and (not (memq impl geiser-impl--impls)) + (require (geiser-impl--impl-feature impl) nil t)) + (add-to-list 'geiser-impl--impls impl))) (defun geiser-impl--unregister (impl) - (setq geiser-impl--impls (remove impl geiser-impl--impls))) + (setq geiser-impl--impls (remove impl geiser-impl--impls)) + (ignore-errors (unload-feature (geiser-impl--impl-feature impl)))) + +(defun geiser-impl--add-to-alist (kind what impl) + (add-to-list 'geiser-impl-implementations-alist (list (list kind what) impl))) (defvar geiser-impl--default-implementation geiser-impl-default-implementation) @@ -74,9 +120,6 @@ ;;; Installing Scheme implementations: -(make-variable-buffer-local - (defvar geiser-impl--implementation nil)) - (defvar geiser-impl--impl-prompt-history nil) (defun geiser-impl--read-impl (&optional prompt impls non-req) @@ -97,37 +140,12 @@ (geiser-impl--install-vars 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))) - (defsubst geiser-impl--module-function (impl) (geiser-impl--sym impl "get-module")) (defsubst geiser-impl--geiser-procedure-function (impl) (geiser-impl--sym impl "geiser-procedure")) -(defsubst geiser-impl--external-help-function (impl) - (let ((f (geiser-impl--sym impl "external-help"))) - (and (fboundp f) f))) - (defsubst geiser-impl--symbol-begin (impl) (geiser-impl--sym impl "symbol-begin")) @@ -136,8 +154,6 @@ (geiser-impl--module-function impl)) (setq geiser-eval--geiser-procedure-function (geiser-impl--geiser-procedure-function impl)) - (setq geiser-doc--external-help-function - (geiser-impl--external-help-function impl)) (setq geiser-completion--symbol-begin-function (geiser-impl--symbol-begin impl))) @@ -150,8 +166,6 @@ (geiser-impl--module-function imp)) (geiser-eval--geiser-procedure-function (geiser-impl--geiser-procedure-function imp)) - (geiser-doc--external-help-function - (geiser-impl--external-help-function imp)) (geiser-completion--symbol-begin-function (geiser-impl--symbol-begin imp))) (funcall thunk))) @@ -171,7 +185,8 @@ (geiser-impl--call-if-bound (geiser-impl--default-implementation) "geiser-procedure" proc)) -(set-default 'geiser-eval--geiser-procedure-function 'geiser-impl-geiser-procedure) +(set-default 'geiser-eval--geiser-procedure-function + 'geiser-impl-geiser-procedure) ;;; Access to implementation specific execution parameters: @@ -191,6 +206,12 @@ (defsubst geiser-impl--startup (impl) (geiser-impl--call-if-bound impl "startup")) +(defsubst geiser-impl--external-help (impl symbol module) + (geiser-impl--call-if-bound impl "external-help" symbol module)) + +(defsubst geiser-impl--display-error (impl module key msg) + (geiser-impl--call-if-bound impl "display-error" module key msg)) + ;;; Access to implementation guessing function: @@ -199,22 +220,58 @@ "Set this buffer local variable to specify the Scheme implementation to be used by Geiser.")) +(defun geiser-impl--match-impl (desc bn) + (let ((rx (if (eq (car desc) 'regexp) + (cadr desc) + (format "^%s" (regexp-quote (cadr desc)))))) + (and rx (string-match-p rx bn)))) + (defun geiser-impl--guess () (or geiser-impl--implementation geiser-scheme-implementation (catch 'impl + (let ((bn (buffer-file-name))) + (when bn + (dolist (x geiser-impl-implementations-alist) + (when (geiser-impl--match-impl (car x) bn) + (throw 'impl (cadr x)))))) (dolist (impl geiser-impl--impls) (when (geiser-impl--call-if-bound impl "guess") (throw 'impl impl)))) (geiser-impl--default-implementation))) +;;; User commands + +(defun geiser-register-implementation () + "Register a new Scheme implementation." + (interactive) + (let ((current geiser-impl-installed-implementations) + (impl (geiser-impl--read-impl "New Scheme implementation: " nil t))) + (unless (geiser-impl--register impl) + (error "geiser-%s.el not found in load-path" impl)) + (when (and (not (memq impl current)) + (y-or-n-p "Remember this implementation using customize? ")) + (customize-save-variable + 'geiser-impl-installed-implementations (cons impl current))))) + +(defun geiser-unregister-implementation () + "Unregister an installed Scheme implementation." + (interactive) + (let* ((current geiser-impl-installed-implementations) + (impl (geiser-impl--read-impl "Forget implementation: " current))) + (geiser-impl--unregister impl) + (when (and impl + (y-or-n-p "Forget permanently using customize? ")) + (customize-save-variable + 'geiser-impl-installed-implementations (remove impl current))))) + + ;;; Unload support (defun geiser-impl-unload-function () (dolist (imp (mapcar 'geiser-impl--impl-feature geiser-impl--impls)) - (when (featurep imp) (unload-feature imp))) - t) + (when (featurep imp) (unload-feature imp t)))) (defun geiser-impl--reload-implementations (impls) (dolist (impl impls) @@ -223,8 +280,11 @@ implementation to be used by Geiser.")) ;;; Initialization: -(mapc 'geiser-impl--register geiser-impl-installed-implementations) +(eval-after-load 'geiser-impl + '(mapc 'geiser-impl--register + (or geiser-impl-installed-implementations '(guile plt)))) (provide 'geiser-impl) + ;;; geiser-impl.el ends here |