summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter <craven@gmx.net>2016-04-26 07:19:36 +0200
committerPeter <craven@gmx.net>2016-04-26 07:19:36 +0200
commitfe2c79adce933b29e4bfcc6ca6f5c5e5546095a5 (patch)
treecd8ed8493a6f7c053d74f0a0cd37e813951df797
parentdcaf849ccdfd488fb26e0d9131bbc59928690e0d (diff)
downloadgeiser-guile-fe2c79adce933b29e4bfcc6ca6f5c5e5546095a5.tar.gz
geiser-guile-fe2c79adce933b29e4bfcc6ca6f5c5e5546095a5.tar.bz2
Add preliminary support for MIT/GNU Scheme.
-rw-r--r--Makefile.am3
-rw-r--r--README1
-rw-r--r--elisp/Makefile.am1
-rw-r--r--elisp/geiser-mit.el162
-rw-r--r--elisp/geiser.el7
-rw-r--r--scheme/Makefile.am6
-rw-r--r--scheme/mit/geiser/compile.scm9
-rw-r--r--scheme/mit/geiser/emacs.scm252
-rw-r--r--scheme/mit/geiser/geiser.pkg20
-rw-r--r--scheme/mit/geiser/load.scm11
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)
diff --git a/README b/README
index 69b34be..e81ca46 100644
--- a/README
+++ b/README
@@ -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))
+