[nongnu] elpa/geiser-mit 29e934c 01/29: Add preliminary support for MIT/GNU Scheme.

[Philip Kaludercic]

branch: elpa/geiser-mit
commit 29e934cda0ccf1d499c316e31451d89bd683e492
Author: Peter <craven@gmx.net>
Commit: Peter <craven@gmx.net>

    Add preliminary support for MIT/GNU Scheme.
---
 elisp/geiser-mit.el           | 162 +++++++++++++++++++++++++++
 scheme/mit/geiser/compile.scm |   9 ++
 scheme/mit/geiser/emacs.scm   | 252 ++++++++++++++++++++++++++++++++++++++++++
 scheme/mit/geiser/geiser.pkg  |  20 ++++
 scheme/mit/geiser/load.scm    |  11 ++
 5 files changed, 454 insertions(+)

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/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))
+