diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | README | 1 | ||||
| -rw-r--r-- | elisp/Makefile.am | 1 | ||||
| -rw-r--r-- | elisp/geiser-mit.el | 162 | ||||
| -rw-r--r-- | elisp/geiser.el | 7 | ||||
| -rw-r--r-- | scheme/Makefile.am | 6 | ||||
| -rw-r--r-- | scheme/mit/geiser/compile.scm | 9 | ||||
| -rw-r--r-- | scheme/mit/geiser/emacs.scm | 252 | ||||
| -rw-r--r-- | scheme/mit/geiser/geiser.pkg | 20 | ||||
| -rw-r--r-- | scheme/mit/geiser/load.scm | 11 |
10 files changed, 471 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index ef3d7bc..4a5c2e2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,12 +25,15 @@ elpa: README.elpa info $(mkdir_p) $(scheme_dir)/guile/geiser $(mkdir_p) $(scheme_dir)/racket/geiser $(mkdir_p) $(scheme_dir)/chicken/geiser + $(mkdir_p) $(scheme_dir)/mit/geiser $(INSTALL_DATA) $(abs_top_srcdir)/scheme/guile/geiser/* \ $(scheme_dir)/guile/geiser $(INSTALL_DATA) $(abs_top_srcdir)/scheme/racket/geiser/* \ $(scheme_dir)/racket/geiser $(INSTALL_DATA) $(abs_top_srcdir)/scheme/chicken/geiser/* \ $(scheme_dir)/chicken/geiser + $(INSTALL_DATA) $(abs_top_srcdir)/scheme/mit/geiser/* \ + $(scheme_dir)/mit/geiser $(INSTALL_DATA) $(srcdir)/doc/geiser.info $(elpa_dir) (cd $(elpa_dir) && install-info --dir=dir geiser.info 2>/dev/null) @@ -33,6 +33,7 @@ - Guile 2.0 or better. - PLT Racket 6.0 or better. - Chicken 4.8.0 or better. + - MIT/GNU Scheme 9.2 or better * Installation diff --git a/elisp/Makefile.am b/elisp/Makefile.am index 085d716..011098e 100644 --- a/elisp/Makefile.am +++ b/elisp/Makefile.am @@ -18,6 +18,7 @@ dist_lisp_LISP = \ geiser-impl.el \ geiser-log.el \ geiser-menu.el \ + geiser-mit.el \ geiser-mode.el \ geiser-racket.el \ geiser-chicken.el \ diff --git a/elisp/geiser-mit.el b/elisp/geiser-mit.el new file mode 100644 index 0000000..f8f7de8 --- /dev/null +++ b/elisp/geiser-mit.el @@ -0,0 +1,162 @@ +;; geiser-mit.el -- MIT/GNU Scheme's implementation of the geiser protocols + +;; 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>. + +(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)) + + +;;; Customization: + +(defgroup geiser-mit nil + "Customization for Geiser's MIT/GNU Scheme flavour." + :group 'geiser) + +(geiser-custom--defcustom geiser-mit-binary + "mit-scheme" + "Name to use to call the MIT/GNU Scheme executable when starting a REPL." + :type '(choice string (repeat string)) + :group 'geiser-mit) + +(geiser-custom--defcustom geiser-mit-source-directory + "" + "The path to the MIT/GNU Scheme sources' src/ directory." + :type 'filename + :group 'geiser-mit) + + +;;; REPL support: + +(defun geiser-mit--binary () + (if (listp geiser-mit-binary) + (car geiser-mit-binary) + geiser-mit-binary)) + +(defun geiser-mit--parameters () + "Return a list with all parameters needed to start MIT/GNU Scheme. +This function uses `geiser-mit-init-file' if it exists." + `("--load" ,(expand-file-name "mit/geiser/load.scm" geiser-scheme-dir)) + ) + +(defconst geiser-mit--prompt-regexp "[0-9]+ ([^)]+) => ") ;; *not* ]=>, that confuses syntax-ppss +(defconst geiser-mit--debugger-prompt-regexp "[0-9]+ error> ") + + +;;; Evaluation support: + +(defun geiser-mit--geiser-procedure (proc &rest args) + (case proc + ((eval compile) + (let ((form (mapconcat 'identity (cdr args) " ")) + (module (cond ((string-equal "'()" (car args)) + "'()") + ((and (car args)) + (concat "'" (car args))) + (t + "#f")))) + (format "(geiser:eval %s '%s)" module 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))))) + +(defconst geiser-mit--module-re + ".*;; package: +\\(([^)]*)\\)") + +(defun geiser-mit--get-module (&optional module) + (cond ((null module) + (save-excursion + (geiser-syntax--pop-to-top) + (if (or (re-search-backward geiser-mit--module-re nil t) + (re-search-forward geiser-mit--module-re nil t)) + (geiser-mit--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-mit--module-cmd (module fmt &optional def) + (when module + (let* ((module (geiser-mit--get-module module)) + (module (cond ((or (null module) (eq module :f)) def) + (t (format "%s" module))))) + (and module (format fmt module))))) + +(defun geiser-mit--enter-command (module) + (geiser-mit--module-cmd module "(geiser:ge '%s)" "()")) + +(defun geiser-mit--exit-command () "(%exit 0)") + +(defun geiser-mit--symbol-begin (module) + (if module + (max (save-excursion (beginning-of-line) (point)) + (save-excursion (skip-syntax-backward "^(>") (1- (point)))) + (save-excursion (skip-syntax-backward "^'-()>") (point)))) + +;; +;; ;;; REPL startup + +(defconst geiser-mit-minimum-version "9.2.1") + +(defun geiser-mit--version (binary) + (shell-command-to-string + (format "%s --quiet --no-init-file --eval %s" + (shell-quote-argument binary) + "'(begin (display (get-subsystem-version-string \"Release\")) (%exit 0))'"))) + +(defconst geiser-mit--path-rx "^In \\([^:\n ]+\\):\n") +(defun geiser-mit--startup (remote) + (let ((geiser-log-verbose-p t)) + (compilation-setup t) + (when (and (stringp geiser-mit-source-directory) + (not (string-empty-p geiser-mit-source-directory))) + (geiser-eval--send/wait (format "(geiser:set-mit-scheme-source-directory %S)" geiser-mit-source-directory))))) + +;;; Implementation definition: + +(define-geiser-implementation mit + (binary geiser-mit--binary) + (arglist geiser-mit--parameters) + (version-command geiser-mit--version) + (minimum-version geiser-mit-minimum-version) + (repl-startup geiser-mit--startup) + (prompt-regexp geiser-mit--prompt-regexp) + (debugger-prompt-regexp geiser-mit--debugger-prompt-regexp) + ;; (enter-debugger geiser-mit--enter-debugger) + (marshall-procedure geiser-mit--geiser-procedure) + (find-module geiser-mit--get-module) + (enter-command geiser-mit--enter-command) + (exit-command geiser-mit--exit-command) + ;; (import-command geiser-mit--import-command) + (find-symbol-begin geiser-mit--symbol-begin) + ;; (display-error geiser-mit--display-error) + ;; (external-help geiser-mit--manual-look-up) + ;; (check-buffer geiser-mit--guess) + ;; (keywords geiser-mit--keywords) + ;; (case-sensitive geiser-mit-case-sensitive-p) + ) + +(geiser-impl--add-to-alist 'regexp "\\.scm$" 'mit t) +(geiser-impl--add-to-alist 'regexp "\\.pkg$" 'mit t) + +(provide 'geiser-mit) diff --git a/elisp/geiser.el b/elisp/geiser.el index 476b4ec..0ae9a43 100644 --- a/elisp/geiser.el +++ b/elisp/geiser.el @@ -97,6 +97,13 @@ "Connect to a remote Geiser Chicken REPL." t) ;;;###autoload +(autoload 'run-mit "geiser-mit" "Start a Geiser MIT/GNU Scheme REPL." t) + +;;;###autoload +(autoload 'switch-to-mit "geiser-mit" + "Start a Geiser MIT/GNU Scheme REPL, or switch to a running one." t) + +;;;###autoload (autoload 'geiser-mode "geiser-mode" "Minor mode adding Geiser REPL interaction to Scheme buffers." t) diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 0e25acc..f44bd15 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -19,4 +19,8 @@ nobase_dist_pkgdata_DATA = \ racket/geiser/startup.rkt \ racket/geiser/user.rkt \ racket/geiser/utils.rkt \ - chicken/geiser/emacs.scm + chicken/geiser/emacs.scm \ + mit/geiser/emacs.scm \ + mit/geiser/geiser.pkg \ + mit/geiser/load.scm \ + mit/geiser/compile.scm diff --git a/scheme/mit/geiser/compile.scm b/scheme/mit/geiser/compile.scm new file mode 100644 index 0000000..5817aa2 --- /dev/null +++ b/scheme/mit/geiser/compile.scm @@ -0,0 +1,9 @@ +(declare (usual-integrations)) + +(load-option 'CREF) + +(with-working-directory-pathname + (directory-pathname (current-load-pathname)) + (lambda () + (cf "emacs") + (cref/generate-constructors "geiser" 'ALL))) diff --git a/scheme/mit/geiser/emacs.scm b/scheme/mit/geiser/emacs.scm new file mode 100644 index 0000000..d94c105 --- /dev/null +++ b/scheme/mit/geiser/emacs.scm @@ -0,0 +1,252 @@ +;;;; package: (runtime geiser) +(declare (usual-integrations)) + +(load-option 'format) + +(define (all-completions prefix environment) + (let (;; (prefix + ;; (if (environment-lookup environment 'PARAM:PARSER-CANONICALIZE-SYMBOLS?) + ;; (string-downcase prefix) + ;; prefix)) + (completions '())) + (for-each-interned-symbol + (lambda (symbol) + (if (and (string-prefix-ci? prefix (symbol-name symbol)) ; was string-prefix?, now defaults to case-insensitive (MIT/GNU Scheme's default) + (environment-bound? environment symbol)) + (set! completions (cons (symbol-name symbol) completions))) + unspecific)) + completions)) + +(define (operator-arglist symbol env) + (let ((type (environment-reference-type env symbol))) + (let ((ans (if (eq? type 'normal) + (let ((binding (environment-lookup env symbol))) + (if (and binding + (procedure? binding)) + (cons symbol (read-from-string (string-trim (with-output-to-string + (lambda () (pa binding)))))) + #f)) + #f ;; macros + ))) + ans))) + +(define (geiser:operator-arglist symbol env) + (let* ((arglist (operator-arglist symbol env)) + (operator symbol)) + (if arglist + (let loop ((arglist (cdr arglist)) + (optionals? #f) + (required '()) + (optional '())) + (cond ((null? arglist) + `(,operator ("args" (("required" ,@(reverse required)) ("optional" ,@(reverse optional)) ("key"))))) ;; ("module" ,module) + ((symbol? arglist) + (loop '() + #t + required + (cons "..." (cons arglist optional)))) + ((eq? (car arglist) #!optional) + (loop (cdr arglist) + #t + required + optional)) + (else + (loop + (cdr arglist) + optionals? + (if optionals? required (cons (car arglist) required)) + (if optionals? (cons (car arglist) optional) optional))))) + '()))) + + +(define (read-from-string str) + (with-input-from-string str + read)) + +(define (all-packages) + (let loop ((package (name->package '()))) ;; system-global-package + (cons package + (append-map loop (package/children package))))) + +(define anonymous-package-prefix + "environment-") + +(define (env->pstring env) + (let ((package (environment->package env))) + (if package + (write-to-string (package/name package)) + (string anonymous-package-prefix (object-hash env))))) + +(define geiser-repl (nearest-repl)) + +(define (set-geiser-repl-prompt! env) + (set-repl/prompt! geiser-repl (format #f "~s =>" (package/name (environment->package env)))) + env) + +(define geiser-env #f) + +(define (get-symbol-definition-location object) + (let ((file (cond ((and (entity? object) + (procedure? object)) + (receive (a b) + (compiled-entry/filename-and-index (entity-procedure object)) + b + a)) + ((compiled-procedure? object) + (receive (a b) + (compiled-entry/filename-and-index object) + b + a)) + (else + '())))) + (fix-mit-source-dir + (if (and (string? file) + (string-suffix? ".inf" file)) + (string-append (substring file 0 (- (string-length file) 3)) "scm") + file)))) + +(define (fix-mit-source-dir filename) + (let ((default-location "/usr/lib/mit-scheme-x86-64/")) + (if (and geiser:mit-scheme-source-directory + (not (string-null? geiser:mit-scheme-source-directory))) + (if (string-prefix? default-location filename) + (string-append geiser:mit-scheme-source-directory (substring filename (string-length default-location) (string-length filename))) + filename) + filename))) + +(define geiser:mit-scheme-source-directory #f) + +;;;; *************************************************************************** + +(define (geiser:eval module form . rest) + rest + (let* ((output (open-output-string)) + (environment (package/environment (find-package (if module module '(user)) #t))) + (result (with-output-to-port output + (lambda () + (eval form environment))))) + (write `((result ,(write-to-string result)) (output . ,(get-output-string output)))))) + +(define (geiser:autodoc ids . rest) + rest + (cond ((null? ids) '()) + ((not (list? ids)) + (geiser:autodoc (list ids))) + ((not (symbol? (car ids))) + (geiser:autodoc (cdr ids))) + (else + (let ((details (map (lambda (id) (geiser:operator-arglist id (->environment '(user)))) ids))) + details)))) + +(define (geiser:module-completions prefix . rest) + rest + (filter (lambda (pstring) + (substring? prefix (write-to-string pstring))) + (map (lambda (package) (env->pstring (package/environment package))) (all-packages)))) + +(define (geiser:completions prefix . rest) + rest + (sort (all-completions prefix (->environment '(user))) + string<?)) + +(define (geiser:ge environment) + (let ((env (package/environment (find-package environment #t)))) + (set-geiser-repl-prompt! env) + (set! geiser-env env)) + (ge environment)) + +(define (geiser:load-file filename) + (load filename)) + +(define (geiser:module-exports module) + (let* ((pkg (find-package module #t)) + (children (map package/name (package/children pkg))) + (env (package/environment pkg))) + (let loop ((vars '()) + (procs '()) + (syntax '()) + (bindings (environment-bindings env))) + (if (null? bindings) + `(("vars" . ,vars) ("procs" . ,procs) ("syntax" . ,syntax) ("modules" . ,(map list children))) + (let* ((binding (car bindings)) + (name (car binding)) + (value (if (null? (cdr binding)) 'unassigned (cadr binding))) + (ref-type (environment-reference-type env name))) + (cond ((eq? 'macro ref-type) + (loop vars + procs + (cons `(,name ("signature")) syntax) + (cdr bindings))) + ((procedure? value) + (loop vars + (cons `(,name ("signature" . ,(geiser:operator-arglist name env))) procs) + syntax + (cdr bindings))) + (else + (loop (cons `(,name) vars) + procs + syntax + (cdr bindings))))))))) + +(define (geiser:symbol-documentation symbol) + (if (environment-bound? geiser-env symbol) + (let ((ref-type (environment-reference-type geiser-env symbol)) + (value (environment-safe-lookup geiser-env symbol))) + (case ref-type + ((macro) + `(("signature" ,symbol ("args")) + ("docstring" . "Macro"))) + ((unassigned) + `(("signature" ,symbol ("args")) + ("docstring" . "Value: Unassigned~%"))) + ((normal) + (if (procedure? value) + (let ((signature (geiser:operator-arglist symbol geiser-env))) + `(("signature" . ,signature) + ("docstring" . ,(format #f "Procedure:~%~a~%" (with-output-to-string (lambda () (pp value))))))) + `(("signature" ,symbol ("args")) + ("docstring" . ,(format #f "Value:~%~a~%" (with-output-to-string (lambda () (pp value)))))) + )) + (else + `(("signature" ,symbol ("args")) + ("docstring" . "Unknown thing..."))))) + '())) + +(define (geiser:symbol-location symbol) + (if (environment-bound? geiser-env symbol) + (let ((ref-type (environment-reference-type geiser-env symbol)) + (value (environment-safe-lookup geiser-env symbol))) + (if (eq? ref-type 'normal) + (let ((file (get-symbol-definition-location value))) + `(("name" . ,symbol) + ("file" . ,file) + ("line"))) + '())) + `(("name" . ,symbol) + ("file") + ("line")))) + +(define (geiser:module-location symbol) + `(("name" . ,symbol) + ("file") + ("line"))) + + +(define (geiser:newline) + #f) + +(define (geiser:no-values) + #f) + +(define (geiser:set-mit-scheme-source-directory dir) + (set! geiser:mit-scheme-source-directory dir)) + +(define (geiser:callers symbol) + symbol + #f) + +(define (geiser:callees symbol) + symbol + #f) + +(set-geiser-repl-prompt! (package/environment (find-package '(user)))) diff --git a/scheme/mit/geiser/geiser.pkg b/scheme/mit/geiser/geiser.pkg new file mode 100644 index 0000000..7f67343 --- /dev/null +++ b/scheme/mit/geiser/geiser.pkg @@ -0,0 +1,20 @@ +;; -*-Scheme-*- +(define-package (runtime geiser) + (files "emacs") + (parent ()) + (export () + geiser:eval + geiser:autodoc + geiser:module-completions + geiser:completions + geiser:ge + geiser:load-file + geiser:module-exports + geiser:symbol-documentation + geiser:symbol-location + geiser:module-location + geiser:callers + geiser:callees + geiser:set-mit-scheme-source-directory + geiser:newline + geiser:no-values)) diff --git a/scheme/mit/geiser/load.scm b/scheme/mit/geiser/load.scm new file mode 100644 index 0000000..2dffd59 --- /dev/null +++ b/scheme/mit/geiser/load.scm @@ -0,0 +1,11 @@ +(declare (usual-integrations)) + +(with-working-directory-pathname + (directory-pathname (current-load-pathname)) + (lambda () + (load "compile.scm") + (load-package-set "geiser" + `()))) + +(add-subsystem-identification! "Geiser" '(0 1)) + |