From d9612b615af3cb55d98503a1a553a070f75149f2 Mon Sep 17 00:00:00 2001
From: Peter <craven@gmx.net>
Date: Tue, 26 Apr 2016 22:31:09 +0200
Subject: Add preliminary support for Chibi Scheme

---
 elisp/geiser-chibi.el          | 159 +++++++++++++++++++++++++++++++++++++++++
 scheme/chibi/geiser/geiser.scm |  49 +++++++++++++
 scheme/chibi/geiser/geiser.sld |   9 +++
 3 files changed, 217 insertions(+)
 create mode 100644 elisp/geiser-chibi.el
 create mode 100644 scheme/chibi/geiser/geiser.scm
 create mode 100644 scheme/chibi/geiser/geiser.sld

diff --git a/elisp/geiser-chibi.el b/elisp/geiser-chibi.el
new file mode 100644
index 0000000..b0ef473
--- /dev/null
+++ b/elisp/geiser-chibi.el
@@ -0,0 +1,159 @@
+;; geiser-chibi.el -- Chibi 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-chibi nil
+  "Customization for Geiser's Chibi Scheme flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-chibi-binary
+    "chibi-scheme"
+  "Name to use to call the Chibi Scheme executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-chibi)
+
+
+;;; REPL support:
+
+(defun geiser-chibi--binary ()
+  (if (listp geiser-chibi-binary)
+      (car geiser-chibi-binary)
+    geiser-chibi-binary))
+
+(defun geiser-chibi--parameters ()
+  "Return a list with all parameters needed to start Chibi Scheme.
+This function uses `geiser-chibi-init-file' if it exists."
+;;  `("--load" ,(expand-file-name "chibi/geiser/load.scm" geiser-scheme-dir))
+  `("-I" ,(expand-file-name "chibi/geiser/" geiser-scheme-dir)
+    "-m" "geiser")
+  )
+
+(defconst geiser-chibi--prompt-regexp "> ")
+
+
+;;; Evaluation support:
+
+(defun geiser-chibi--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-chibi--module-re
+;;   ".*;; package: +\\(([^)]*)\\)")
+
+(defun geiser-chibi--get-module (&optional module)
+  (cond ((null module)
+         :f)
+        ((listp module) module)
+        ((stringp module)
+         (condition-case nil
+             (car (geiser-syntax--read-from-string module))
+           (error :f)))
+        (t :f)))
+
+;; (defun geiser-chibi--module-cmd (module fmt &optional def)
+;;   (when module
+;;     (let* ((module (geiser-chibi--get-module module))
+;;            (module (cond ((or (null module) (eq module :f)) def)
+;;                          (t (format "%s" module)))))
+;;       (and module (format fmt module)))))
+
+;; (defun geiser-chibi--enter-command (module)
+;;   (geiser-chibi--module-cmd module "(geiser:ge '%s)" "()"))
+
+(defun geiser-chibi--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))))
+
+(defun geiser-chibi--import-command (module)
+  (format "(import %s)" module))
+
+(defun geiser-chibi--exit-command () "(exit 0)")
+;; 
+;; ;;; REPL startup
+
+(defconst geiser-chibi-minimum-version "0.7.3")
+
+(defun geiser-chibi--version (binary)
+  (second (split-string (shell-command-to-string
+                         (format "%s -V"
+                                 (shell-quote-argument binary)))
+                        " ")))
+
+;; (defconst geiser-chibi--path-rx "^In \\([^:\n ]+\\):\n")
+(defun geiser-chibi--startup (remote)
+  (let ((geiser-log-verbose-p t))
+    (compilation-setup t)
+    ;; (when (and (stringp geiser-chibi-source-directory)
+    ;;            (not (string-empty-p geiser-chibi-source-directory)))
+    ;;   (geiser-eval--send/wait (format "(geiser:set-chibi-scheme-source-directory %S)" geiser-chibi-source-directory)))
+    ))
+
+;;; Implementation definition:
+
+(define-geiser-implementation chibi
+  (binary geiser-chibi--binary)
+  (arglist geiser-chibi--parameters)
+  (version-command geiser-chibi--version)
+  (minimum-version geiser-chibi-minimum-version)
+  (repl-startup geiser-chibi--startup)
+  (prompt-regexp geiser-chibi--prompt-regexp)
+  (debugger-prompt-regexp nil) ;; geiser-chibi--debugger-prompt-regexp
+  ;; (enter-debugger geiser-chibi--enter-debugger)
+  (marshall-procedure geiser-chibi--geiser-procedure)
+  (find-module geiser-chibi--get-module)
+  ;; (enter-command geiser-chibi--enter-command)
+  (exit-command geiser-chibi--exit-command)
+  (import-command geiser-chibi--import-command)
+  (find-symbol-begin geiser-chibi--symbol-begin)
+  ;; (display-error geiser-chibi--display-error)
+  ;; (external-help geiser-chibi--manual-look-up)
+  ;; (check-buffer geiser-chibi--guess)
+  ;; (keywords geiser-chibi--keywords)
+  ;; (case-sensitive geiser-chibi-case-sensitive-p)
+  )
+
+;; notes: (available-modules) in (chibi modules)
+;; (env-exports (module-env (find-module '(scheme char)))), modules: (meta) (chibi modules) (chibi)
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'chibi t)
+(geiser-impl--add-to-alist 'regexp "\\.sld$" 'chibi t)
+
+(provide 'geiser-chibi)
+
diff --git a/scheme/chibi/geiser/geiser.scm b/scheme/chibi/geiser/geiser.scm
new file mode 100644
index 0000000..a6b37f3
--- /dev/null
+++ b/scheme/chibi/geiser/geiser.scm
@@ -0,0 +1,49 @@
+(define (all-environment-exports environment prefix)
+  (if environment
+      (append (filter (lambda (identifier)
+                        (if (string=? prefix "")
+                            #t
+                            (string-contains identifier prefix)))
+                      (map symbol->string (env-exports environment)))
+              (all-environment-exports (env-parent environment) prefix))
+      '()))
+
+(define (geiser:completions prefix . rest)
+  rest
+  (sort (all-environment-exports (current-environment) prefix)
+        string-ci<?))
+
+(define (write-to-string form)
+  (let ((out (open-output-string)))
+    (write form out)
+    (get-output-string out)))
+
+(define (geiser:eval module form . rest)
+  rest
+  (let ((output (open-output-string))
+        (result (if module
+                    (let ((mod (module-env (find-module module))))
+                      (eval form mod))
+                    (eval form))))
+    (write `((result ,(write-to-string result))
+             (output . ,(get-output-string output))))
+    (values)))
+
+(define (geiser:module-completions prefix . rest)
+  (let ((modules (map car (available-modules))))
+    (map write-to-string
+         (delete-duplicates
+          (filter (lambda (module)
+                    (if (string=? "" prefix)
+                        #t
+                        (string-contains prefix (write-to-string module))))
+                  modules)))))
+
+(define (geiser:autodoc ids . rest)
+  '())
+
+(define (geiser:no-values)
+  #f)
+
+(define (geiser:newline)
+  #f)
diff --git a/scheme/chibi/geiser/geiser.sld b/scheme/chibi/geiser/geiser.sld
new file mode 100644
index 0000000..a6e2704
--- /dev/null
+++ b/scheme/chibi/geiser/geiser.sld
@@ -0,0 +1,9 @@
+(define-library (geiser)
+  (export geiser:completions
+          geiser:eval
+          geiser:autodoc
+          geiser:module-completions
+          geiser:no-values
+          geiser:newline)
+  (import (scheme small) (chibi modules) (chibi) (meta) (chibi string) (srfi 1) (srfi 95))
+  (include "geiser.scm"))
-- 
cgit v1.2.3