diff options
| -rw-r--r-- | elisp/geiser-gambit.el | 318 | ||||
| -rw-r--r-- | elisp/geiser-impl.el | 2 | ||||
| -rw-r--r-- | scheme/gambit/geiser/gambit.scm | 4 |
3 files changed, 323 insertions, 1 deletions
diff --git a/elisp/geiser-gambit.el b/elisp/geiser-gambit.el new file mode 100644 index 0000000..cee1e03 --- /dev/null +++ b/elisp/geiser-gambit.el @@ -0,0 +1,318 @@ +;; geiser-gambit.el -- gambit's implementation of the geiser protocols + +;; Copyright (C) 2014, 2015, 2019 Daniel Leslie + +;; Based on geiser-guile.el by Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Sun Mar 08, 2009 23:03 + +;; Gambit in geiser, thank you to Chris Blom for the start he did few years ago +;; https://github.com/ChrisBlom + +(require 'geiser-connection) +(require 'geiser-syntax) +(require 'geiser-custom) +(require 'geiser-base) +(require 'geiser-eval) +(require 'geiser-edit) +(require 'geiser-log) +(require 'geiser) + +(require 'compile) +(require 'info-look) + +(eval-when-compile (require 'cl)) + +(defconst geiser-gambit-builtin-keywords + '("##debug-repl")) + +;;; Customization + +(defgroup geiser-gambit nil + "Customization for Geiser's Gambit flavour." + :group 'geiser) + +;; define the interpretor for geiser. +;; the geiser-costum--defcustom is a macro that will +;; call a declaration into the documentation of the +;; structure of the methode and then define the method +;; with a defcustom: define a variable that represents an option users might want to set +(geiser-custom--defcustom geiser-gambit-binary + (cond ((eq system-type 'windows-nt) '("gsi.exe")) ;; not sure if the -:c is ok here + ((eq system-type 'darwin) "gsi") + (t "gsi")) + "Name to use to call the gambit executable when starting a REPL." + :type '(choice string (repeat string)) + :group 'geiser-gambit) + +(geiser-custom--defcustom geiser-gambit-load-path nil + "A list of paths to be added to gambit's load path when it's +started." + :type '(repeat file) + :group 'geiser-gambit) + +(geiser-custom--defcustom geiser-gambit-compile-geiser-p t + "Non-nil means that the Geiser runtime will be compiled on load." + :type 'boolean + :group 'geiser-gambit) + +(geiser-custom--defcustom geiser-gambit-init-file "~/.gambit-geiser" + "Initialization file with user code for the Gambit REPL. +If all you want is to load ~/.gambit, set +`geiser-gambit-load-init-file-p' instead." + :type 'string + :group 'geiser-gambit) + +(geiser-custom--defcustom geiser-gambit-load-init-file-p nil + "Whether to load ~/.gambit when starting Gambit. +Note that, due to peculiarities in the way Gambit loads its init +file, using `geiser-gambit-init-file' is not equivalent to setting +this variable to t." + :type 'boolean + :group 'geiser-gambit) + +(geiser-custom--defcustom geiser-gambit-extra-keywords nil + "Extra keywords highlighted in gambit scheme buffers." + :type '(repeat string) + :group 'geiser-gambit) + +(geiser-custom--defcustom geiser-gambit-case-sensitive-p t + "Non-nil means keyword highlighting is case-sensitive." + :type 'boolean + :group 'geiser-gambit) + + + +;; TODO path for debugger and debugging functions + + +;;; REPL support: + +(defun geiser-gambit--binary () + (if (listp geiser-gambit-binary) + (car geiser-gambit-binary) + geiser-gambit-binary)) + +;;(defun geiser-gambit--parameters () +;; "Return a list with all parameters needed to start Gambit. +;;This function uses `geiser-gambit-init-file' if it exists." +;;;; (let ((init-file (and (stringp geiser-gambit-init-file) +;;;; (expand-file-name geiser-gambit-init-file))) +;;;; (n-flags (and (not geiser-gambit-load-init-file-p) '("-n")))) +;;;; `(,@(and (listp geiser-gambit-binary) (cdr geiser-gambit-binary)) +;;;; ,@n-flags "-include-path" ,(expand-file-name "gambit/" geiser-scheme-dir) +;;;; ,@(apply 'append (mapcar (lambda (p) (list "-include-path" p)) +;;;; geiser-gambit-load-path)) +;;;; ,@(and init-file (file-readable-p init-file) (list init-file))))) +;; `("-I" ,(expand-file-name "gambit/geiser/" geiser-scheme-dir))) + +(defun geiser-gambit--parameters () '("-:d-")) ;; uses -:d to pipe to stdin and stdout + +(defconst geiser-gambit--prompt-regexp "[0-9]*> ") + +;;; Evaluation support: +(defun geiser-gambit--geiser-procedure (proc &rest args) + (let ((fmt + (case proc + ((eval compile) + (let ((form (mapconcat 'identity (cdr args) " "))) + (format ",geiser-eval %s %s" (or (car args) "#f") form))) + ((load-file compile-file) + (format ",geiser-load-file %s" (car args))) + ((no-values) + ",geiser-no-values") + (t + (let ((form (mapconcat 'identity args " "))) + (format "(geiser-%s %s)" proc form)))))) + ;;(message fmt) + fmt)) + +(defconst geiser-gambit--module-re + "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)") + +(defun geiser-gambit--module-cmd (module fmt &optional def) + (when module + (let* ((module (geiser-gambit--get-module module)) + (module (cond ((or (null module) (eq module :f)) def) + (t (format "%s" module))))) + (and module (format fmt module))))) + +(defun geiser-gambit--get-module (&optional module) + (cond ((null module) + (save-excursion + (geiser-syntax--pop-to-top) + (if (or (re-search-backward geiser-gambit--module-re nil t) + (looking-at geiser-gambit--library-re) + (re-search-forward geiser-gambit--module-re nil t)) + (geiser-gambit--get-module (match-string-no-properties 1)) + :f))) + ((listp module) module) + ((stringp module) + (condition-case nil + (car (geiser-syntax--read-from-string module)) + (error :f))) + (t :f))) + +(defun geiser-gambit--import-command (module) + (geiser-gambit--module-cmd module ",use %s")) + +(defun geiser-gambit--enter-command (module) + (geiser-gambit--module-cmd module ",m %s" module)) + +(defun geiser-gambit--exit-command () ",q") + +(defun geiser-gambit--symbol-begin (module) + (save-excursion (skip-syntax-backward "^-()>") (point))) + +(defun geiser-gambit--version (binary) + (car (process-lines binary "-c" "(display (version))"))) + +(defun connect-to-gambit () + "Start a gambit REPL connected to a remote process." + (interactive) + (geiser-connect 'gambit)) + +;; error display + +;;; Error display + +(defun geiser-gambit--display-error (module key msg) + (newline) + (when (stringp msg) + (save-excursion (insert msg)) + (geiser-edit--buttonize-files)) + (and (not key) msg (not (zerop (length msg))))) + +;;; Trying to ascertain whether a buffer is Gambit Scheme: + +(defconst geiser-gambit--guess-re + (regexp-opt (append '("gsi" "gambit") geiser-gambit-builtin-keywords))) + +(defun geiser-gambit--guess () + (save-excursion + (goto-char (point-min)) + (re-search-forward geiser-gambit--guess-re nil t))) + +(defun geiser-gambit--external-help (id module) + "Loads gambit doc into a buffer" + (browse-url (format "http://api.call-cc.org/cdoc?q=%s&query-name=Look+up" id))) + +;;; Keywords and syntax + +(defun geiser-gambit--keywords () + `((,(format "[[(]%s\\>" (regexp-opt geiser-gambit-builtin-keywords 1)) . 1))) + +(geiser-syntax--scheme-indent + (receive 2) + (match 1) + (match-lambda 0) + (match-lambda* 0) + (match-let scheme-let-indent) + (match-let* 1) + (match-letrec 1) + (declare 0) + (cond-expand 0) + (let-values scheme-let-indent) + (let*-values scheme-let-indent) + (letrec-values 1) + (letrec* 1) + (parameterize scheme-let-indent) + (let-location 1) + (foreign-lambda 2) + (foreign-lambda* 2) + (foreign-primitive 2) + (foreign-safe-lambda 2) + (foreign-safe-lambda* 2) + (set! 1) + (let-optionals* 2) + (let-optionals 2) + (condition-case 1) + (fluid-let 1) + (and-let* 1) + (assume 1) + (cut 1) + (cute 1) + (when 1) + (unless 1) + (dotimes 1) + (compiler-typecase 1) + (ecase 1) + (use 0) + (require-extension 0) + (import 0) + (handle-exceptions 2) + (regex-case 1) + (define-inline 1) + (define-constant 1) + (define-syntax-rule 1) + (define-record-type 1) + (define-values 1) + (define-record 1) + (define-specialization 1) + (define-type 1) + (with-input-from-pipe 1) + (select 1) + (functor 3) + (define-interface 1) + (module 2)) + +;;; REPL startup + +(defconst geiser-gambit-minimum-version "v4.7.3") + +(defun geiser-gambit--version (binary) + (shell-command-to-string (format "%s -e \"(display (##system-version-string))\"" + binary))) + +(defun connect-to-gambit () + "Start a Gambit REPL connected to a remote process." + (interactive) + (geiser-connect 'gambit)) + +(defun geiser-gambit--startup (remote) + (compilation-setup t) + (let ((geiser-log-verbose-p t) + (geiser-gambit-load-file (expand-file-name "gambit/geiser/emacs.scm" geiser-scheme-dir))) + (if geiser-gambit-compile-geiser-p + (geiser-eval--send/wait (format "(use utils)(compile-file \"%s\")(import geiser)" + geiser-gambit-load-file)) + (geiser-eval--send/wait (format "(load \"%s\")" + geiser-gambit-load-file))))) + +;;; Implementation definition: + +(define-geiser-implementation gambit + (unsupported-procedures '(callers callees generic-methods)) + (binary geiser-gambit--binary) + (arglist geiser-gambit--parameters) + (version-command geiser-gambit--version) + (minimum-version geiser-gambit-minimum-version) + (repl-startup geiser-gambit--startup) + (prompt-regexp geiser-gambit--prompt-regexp) + (debugger-prompt-regexp nil) + (enter-debugger nil) + (marshall-procedure geiser-gambit--geiser-procedure) + (find-module geiser-gambit--get-module) + (enter-command geiser-gambit--enter-command) + (exit-command geiser-gambit--exit-command) + (import-command geiser-gambit--import-command) + (find-symbol-begin geiser-gambit--symbol-begin) + (display-error geiser-gambit--display-error) + (external-help geiser-gambit--external-help) + (check-buffer geiser-gambit--guess) + (keywords geiser-gambit--keywords) + (case-sensitive geiser-gambit-case-sensitive-p)) + +(geiser-impl--add-to-alist 'regexp "\\.scm$" 'gambit t) +(geiser-impl--add-to-alist 'regexp "\\.release-info$" 'gambit t) +(geiser-impl--add-to-alist 'regexp "\\.meta$" 'gambit t) +(geiser-impl--add-to-alist 'regexp "\\.setup$" 'gambit t) + +(provide 'geiser-gambit) + + diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el index c14db42..0455772 100644 --- a/elisp/geiser-impl.el +++ b/elisp/geiser-impl.el @@ -29,7 +29,7 @@ :group 'geiser-implementation) (geiser-custom--defcustom geiser-active-implementations - '(guile racket chicken chez mit chibi) + '(guile racket chicken chez mit chibi gambit) "List of active installed Scheme implementations." :type '(repeat symbol) :group 'geiser-implementation) diff --git a/scheme/gambit/geiser/gambit.scm b/scheme/gambit/geiser/gambit.scm new file mode 100644 index 0000000..805fe31 --- /dev/null +++ b/scheme/gambit/geiser/gambit.scm @@ -0,0 +1,4 @@ +;; TODO implement functions required by geiser + +(display "loaded gambit.scm\n") + |