From 383585e44e56be0e690ad96895f73abf8454d3be Mon Sep 17 00:00:00 2001
From: Dan Leslie <dan@ironoxide.ca>
Date: Thu, 20 Nov 2014 17:36:50 -0800
Subject: Initial Chicken support

---
 AUTHORS                         |   1 +
 INSTALL                         |  10 +
 Makefile.am                     |   3 +
 README                          |   4 +
 README.elpa                     |  12 +
 elisp/Makefile.am               |   1 +
 elisp/geiser-chicken.el         | 295 ++++++++++++++++++
 elisp/geiser-impl.el            |   2 +-
 elisp/geiser.el                 |  12 +
 scheme/Makefile.am              |   3 +-
 scheme/chicken/geiser/emacs.scm | 665 ++++++++++++++++++++++++++++++++++++++++
 11 files changed, 1006 insertions(+), 2 deletions(-)
 create mode 100644 elisp/geiser-chicken.el
 create mode 100644 scheme/chicken/geiser/emacs.scm

diff --git a/AUTHORS b/AUTHORS
index f8de9b2..fecd39d 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -11,5 +11,6 @@ Ray Racine
 Nick Parker
 Darren Hoo
 Ludovic Courtès
+Daniel J. Leslie
 
 See also <https://github.com/jaor/geiser/contributors>.
diff --git a/INSTALL b/INSTALL
index 5148ea4..ea45e67 100644
--- a/INSTALL
+++ b/INSTALL
@@ -50,6 +50,16 @@ package-install-file.
 
     (require 'geiser-install)
 
+* Chicken Addendum
+    These steps are necessary to fully support Chicken Scheme, but are
+    not required for any other scheme.
+
+    - Install the necessary support eggs:
+      $ chicken-install -s apropos chicken-doc
+    - Update the Chicken documentation database:
+      $ cd `csi -p '(chicken-home)'`
+      $ curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | sudo tar zx
+
     You're ready to go!
 
 Geiser's makefile accepts also all those other standard autotools
diff --git a/Makefile.am b/Makefile.am
index 38be6b2..75d3ac4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -25,10 +25,13 @@ elpa: README.elpa info
 
 	$(mkdir_p) $(scheme_dir)/guile/geiser
 	$(mkdir_p) $(scheme_dir)/racket/geiser
+	$(mkdir_p) $(scheme_dir)/chicken/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) $(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 3537cea..cc8bf7e 100644
--- a/README
+++ b/README
@@ -32,6 +32,7 @@
     supported scheme implementations:
       - Guile 2.0 or better.
       - PLT Racket 5.3 or better.
+      - Chicken 4.8.0 or better.
 
 * Installation
 
@@ -42,6 +43,9 @@
   or byte-compiled and installed after perfoming the standard
   configure/make/make install dance.  See the INSTALL file for more details.
 
+  Chicken Scheme requires additional steps which are detailed in the INSTALL
+  file and the README.elpa file.
+
 * Basic configuration
 
   The loading invocations above install all supported Scheme
diff --git a/README.elpa b/README.elpa
index 6b1cd66..e470dcc 100644
--- a/README.elpa
+++ b/README.elpa
@@ -34,6 +34,18 @@ Main functionalities:
     - Support for inline images in schemes, such as Racket, that treat
       them as first order values.
 
+
+Chicken Addendum:
+    These steps are necessary to fully support Chicken Scheme, but are
+    not required for any other scheme.
+
+    - Install the necessary support eggs:
+      $ chicken-install -s apropos chicken-doc
+
+    - Update the Chicken documentation database:
+      $ cd `csi -p '(chicken-home)'`
+      $ curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | sudo tar zx
+
 See http://www.nongnu.org/geiser/ for the full manual in HTML form, or
 the the info manual installed by this package.
 
diff --git a/elisp/Makefile.am b/elisp/Makefile.am
index 4b2b511..085d716 100644
--- a/elisp/Makefile.am
+++ b/elisp/Makefile.am
@@ -20,6 +20,7 @@ dist_lisp_LISP = \
    geiser-menu.el \
    geiser-mode.el \
    geiser-racket.el \
+   geiser-chicken.el \
    geiser-popup.el \
    geiser-reload.el \
    geiser-repl.el \
diff --git a/elisp/geiser-chicken.el b/elisp/geiser-chicken.el
new file mode 100644
index 0000000..8abdec3
--- /dev/null
+++ b/elisp/geiser-chicken.el
@@ -0,0 +1,295 @@
+;; geiser-chicken.el -- chicken's implementation of the geiser protocols
+
+;; Copyright (C) 2014 Daniel Leslie
+
+;; Based on geiser-guile.el by Jose Antonio Ortego Ruize
+
+;; 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
+
+
+(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-chicken-builtin-keywords
+  '("and-let*" "assume" "compiler-typecase" "cond-expand" "condition-case"
+    "cut" "cute" "declare" "define-constant" "define-inline" "define-interface"
+    "define-record" "define-record-type" "define-specialization"
+    "define-syntax-rule" "define-type" "define-values" "dotimes" "ecase" 
+    "fluid-let" "foreign-lambda" "foreign-lambda*" "foreign-primitive" 
+    "foreign-safe-lambda" "foreign-safe-lambda*" "functor" "handle-exceptions"
+    "import" "let*-values" "let-location" "let-optionals" "let-optionals*" 
+    "let-values" "letrec*" "letrec-values" "match-letrec" "module" 
+    "parameterize" "regex-case" "require-extension" "select" "set!"
+    "unless" "use" "when" "with-input-from-pipe" "match" "match-lambda"
+    "match-lambda*" "match-let" "match-let*" "receive"))
+
+;;; Customization:
+
+(defgroup geiser-chicken nil
+  "Customization for Geiser's Chicken flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-chicken-binary
+  (cond ((eq system-type 'windows-nt) "csi.exe")
+        ((eq system-type 'darwin) "csi")
+        (t "csi"))
+  "Name to use to call the Chicken executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-load-path nil
+  "A list of paths to be added to Chicken's load path when it's
+started."
+  :type '(repeat file)
+  :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-init-file "~/.chicken-geiser"
+  "Initialization file with user code for the Chicken REPL.
+If all you want is to load ~/.csirc, set
+`geiser-chicken-load-init-file-p' instead."
+  :type 'string
+  :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-load-init-file-p nil
+  "Whether to load ~/.chicken when starting Chicken.
+Note that, due to peculiarities in the way Chicken loads its init
+file, using `geiser-chicken-init-file' is not equivalent to setting
+this variable to t."
+  :type 'boolean
+  :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-extra-keywords nil
+  "Extra keywords highlighted in Chicken scheme buffers."
+  :type '(repeat string)
+  :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-case-sensitive-p t
+  "Non-nil means keyword highlighting is case-sensitive."
+  :type 'boolean
+  :group 'geiser-chicken)
+
+
+;;; REPL support:
+
+(defun geiser-chicken--binary ()
+  (if (listp geiser-chicken-binary)
+      (car geiser-chicken-binary)
+    geiser-chicken-binary))
+
+(defun geiser-chicken--parameters ()
+  "Return a list with all parameters needed to start Chicken.
+This function uses `geiser-chicken-init-file' if it exists."
+  (let ((init-file (and (stringp geiser-chicken-init-file)
+                        (expand-file-name geiser-chicken-init-file)))
+        (n-flags (and (not geiser-chicken-load-init-file-p) '("-n"))))
+  `(,@(and (listp geiser-chicken-binary) (cdr geiser-chicken-binary))
+    ,@n-flags "-include-path" ,(expand-file-name "chicken/" geiser-scheme-dir)
+    ,@(apply 'append (mapcar (lambda (p) (list "-include-path" p))
+                             geiser-chicken-load-path))
+    ,@(and init-file (file-readable-p init-file) (list init-file)))))
+
+(defconst geiser-chicken--prompt-regexp "#[^;]*;[^:0-9]*:?[0-9]+> ")
+
+;;; Evaluation support:
+
+(defun geiser-chicken--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-chicken--module-re
+  "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)")
+
+(defun geiser-chicken--get-module (&optional module)
+  (cond ((null module)
+         (save-excursion
+           (geiser-syntax--pop-to-top)
+           (if (or (re-search-backward geiser-chicken--module-re nil t)
+                   (looking-at geiser-chicken--module-re)
+                   (re-search-forward geiser-chicken--module-re nil t))
+               (geiser-chicken--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-chicken--module-cmd (module fmt &optional def)
+  (when module
+    (let* ((module (geiser-chicken--get-module module))
+           (module (cond ((or (null module) (eq module :f)) def)
+                         (t (format "%s" module)))))
+      (and module (format fmt module)))))
+
+(defun geiser-chicken--import-command (module)
+  (geiser-chicken--module-cmd module "(use %s)"))
+
+(defun geiser-chicken--enter-command (module)
+  (geiser-chicken--module-cmd module ",m %s" module))
+
+(defun geiser-chicken--exit-command () ",q")
+
+(defun geiser-chicken--symbol-begin (module)
+  (save-excursion (skip-syntax-backward "^-()>") (point)))
+
+;;; Error display
+
+(defun geiser-chicken--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 Chicken Scheme:
+
+(defconst geiser-chicken--guess-re
+  (regexp-opt (append '("csi" "chicken") geiser-chicken-builtin-keywords)))
+
+(defun geiser-chicken--guess ()
+  (save-excursion
+    (goto-char (point-min))
+    (re-search-forward geiser-chicken--guess-re nil t)))
+
+(defun geiser-chicken--external-help (id module)
+  "Loads chicken 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-chicken--keywords ()
+  `((,(format "[[(]%s\\>" (regexp-opt geiser-chicken-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-chicken-minimum-version "4.8.0.0")
+
+(defun geiser-chicken--version (binary)
+  (shell-command-to-string (format "%s -e \"(display (chicken-version))\"" 
+                                   binary)))
+
+(defun connect-to-chicken ()
+  "Start a Chicken REPL connected to a remote process."
+  (interactive)
+  (geiser-connect 'chicken))
+
+(defun geiser-chicken--startup (remote)
+  (compilation-setup t)
+  (let ((geiser-log-verbose-p t))
+    (geiser-eval--send/wait (format "(load \"%s\")\n" 
+                                    (expand-file-name "chicken/geiser/emacs.scm" geiser-scheme-dir)))))
+
+;;; Implementation definition:
+
+(define-geiser-implementation chicken
+  (unsupported-procedures '(callers callees generic-methods))
+  (binary geiser-chicken--binary)
+  (arglist geiser-chicken--parameters)
+  (version-command geiser-chicken--version)
+  (minimum-version geiser-chicken-minimum-version)
+  (repl-startup geiser-chicken--startup)
+  (prompt-regexp geiser-chicken--prompt-regexp)
+  (debugger-prompt-regexp nil)
+  (enter-debugger nil)
+  (marshall-procedure geiser-chicken--geiser-procedure)
+  (find-module geiser-chicken--get-module)
+  (enter-command geiser-chicken--enter-command)
+  (exit-command geiser-chicken--exit-command)
+  (import-command geiser-chicken--import-command)
+  (find-symbol-begin geiser-chicken--symbol-begin)
+  (display-error geiser-chicken--display-error)
+  (external-help geiser-chicken--external-help)
+  (check-buffer geiser-chicken--guess)
+  (keywords geiser-chicken--keywords)
+  (case-sensitive geiser-chicken-case-sensitive-p))
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'chicken t)
+(geiser-impl--add-to-alist 'regexp "\\.release-info$" 'chicken t)
+(geiser-impl--add-to-alist 'regexp "\\.meta$" 'chicken t)
+(geiser-impl--add-to-alist 'regexp "\\.setup$" 'chicken t)
+
+(provide 'geiser-chicken)
diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el
index 38d22fa..d2b440a 100644
--- a/elisp/geiser-impl.el
+++ b/elisp/geiser-impl.el
@@ -28,7 +28,7 @@
   :type 'symbol
   :group 'geiser-implementation)
 
-(geiser-custom--defcustom geiser-active-implementations '(guile racket)
+(geiser-custom--defcustom geiser-active-implementations '(guile racket chicken)
   "List of active installed Scheme implementations."
   :type '(repeat symbol)
   :group 'geiser-implementation)
diff --git a/elisp/geiser.el b/elisp/geiser.el
index 1905a0c..fb5b46a 100644
--- a/elisp/geiser.el
+++ b/elisp/geiser.el
@@ -80,6 +80,17 @@
 (autoload 'connect-to-racket "geiser-racket"
   "Connect to a remote Geiser Racket REPL." t)
 
+;;;###autoload
+(autoload 'run-chicken "geiser-chicken" "Start a Geiser Chicken REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-chicken "geiser-chicken"
+  "Start a Geiser Chicken REPL, or switch to a running one." t)
+
+;;;###autoload
+(autoload 'connect-to-chicken "geiser-chicken"
+  "Connect to a remote Geiser Chicken REPL." t)
+
 ;;;###autoload
 (autoload 'geiser-mode "geiser-mode"
   "Minor mode adding Geiser REPL interaction to Scheme buffers." t)
@@ -109,6 +120,7 @@
         geiser-guile
         geiser-image
         geiser-racket
+        geiser-chicken
         geiser-implementation
         geiser-xref))
 
diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index 2eaadfe..0e25acc 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -18,4 +18,5 @@ nobase_dist_pkgdata_DATA = \
   racket/geiser/server.rkt \
   racket/geiser/startup.rkt \
   racket/geiser/user.rkt \
-  racket/geiser/utils.rkt
+  racket/geiser/utils.rkt \
+  chicken/geiser/emacs.scm
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
new file mode 100644
index 0000000..8ec6bf5
--- /dev/null
+++ b/scheme/chicken/geiser/emacs.scm
@@ -0,0 +1,665 @@
+(module geiser
+  ;; A bunch of these needn't be toplevel functions
+  (geiser-eval
+   geiser-no-values
+   geiser-newline
+   geiser-start-server
+   geiser-completions
+   geiser-autodoc
+   geiser-object-signature
+   geiser-symbol-location
+   geiser-symbol-documentation
+   geiser-find-file
+   geiser-add-to-load-path
+   geiser-load-file
+   geiser-compile-file
+   geiser-compile
+   geiser-module-exports
+   geiser-module-path
+   geiser-module-location
+   geiser-module-completions
+   geiser-macroexpand
+   make-geiser-toplevel-bindings)
+
+  ;; Necessary built in units
+  (import chicken 
+          scheme 
+          extras 
+          data-structures 
+          ports 
+          csi
+          irregex
+          srfi-1
+          posix
+          utils)
+
+  (use apropos
+       regex
+       chicken-doc
+       tcp
+       srfi-18)
+
+  (define use-debug-log #f)
+  
+  (if use-debug-log
+   (use posix))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbol lists
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-r4rs-symbols
+    (make-parameter
+     '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr
+           caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar
+           caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar
+           cddadr cdddar cddddr set-car! set-cdr! null? list? list length
+           list-tail list-ref append reverse memq memv member assq assv assoc
+           symbol? symbol->string string->symbol number? integer? exact? real?
+           complex? inexact? rational? zero? odd? even? positive? negative?
+           max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs
+           floor ceiling truncate round exact->inexact inexact->exact exp log
+           expt sqrt sin cos tan asin acos atan number->string string->number
+           char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<?
+           char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace?
+           char-numeric? char-upper-case? char-lower-case? char-upcase
+           char-downcase char->integer integer->char string? string=? string>?
+           string<? string>=? string<=? string-ci=? string-ci<? string-ci>?
+           string-ci>=? string-ci<=?  make-string string-length string-ref
+           string-set! string-append string-copy string->list list->string
+           substring string-fill! vector? make-vector vector-ref vector-set!
+           string vector vector-length vector->list list->vector vector-fill!
+           procedure? map for-each apply force call-with-current-continuation
+           input-port? output-port? current-input-port current-output-port
+           call-with-input-file call-with-output-file open-input-file
+           open-output-file close-input-port close-output-port load
+           read eof-object? read-char peek-char write display write-char
+           newline with-input-from-file with-output-to-file eval char-ready?
+           imag-part real-part magnitude numerator denominator
+           scheme-report-environment null-environment interaction-environment
+           else)))
+  
+  (define geiser-r5rs-symbols
+    (make-parameter
+     '(abs acos and angle append apply asin assoc assq assv atan begin 
+           boolean? caar cadr call-with-current-continuation 
+           call-with-input-file call-with-output-file call-with-values 
+           car case cdddar cddddr cdr ceiling char->integer char-alphabetic?
+           char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase
+           char-lower-case? char-numeric? char-ready? char-upcase
+           char-upper-case? char-whitespace? char<=? char<? char=? char>=?
+           char>? char? close-input-port close-output-port complex? cond cons
+           cos current-input-port current-output-port define define-syntax
+           delay denominator display do dynamic-wind else eof-object? eq?
+           equal? eqv? eval even? exact->inexact exact? exp expt floor
+           for-each force gcd if imag-part inexact->exact inexact? input-port?
+           integer->char integer? interaction-environment lambda lcm length
+           let let* let-syntax letrec letrec-syntax list list->string 
+           list->vector list-ref list-tail list? load log magnitude make-polar
+           make-rectangular make-string make-vector map max member memq memv 
+           min modulo negative? newline not null-environment null? 
+           number->string number? numerator odd? open-input-file 
+           open-output-file or output-port? pair? peek-char port? positive? 
+           procedure? quasiquote quote quotient rational? rationalize read 
+           read-char real-part real? remainder reverse round 
+           scheme-report-environment set! set-car! set-cdr! setcar sin sqrt 
+           string string->list string->number string->symbol string-append 
+           string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? 
+           string-copy string-fill! string-length string-ref string-set! 
+           string<=? string<? string=? string>=? string>? string? substring 
+           symbol->string symbol? syntax-rules tan transcript-off transcript-on 
+           truncate values vector vector->list vector-fill! vector-length 
+           vector-ref vector-set! vector? with-input-from-file with-output-to-file 
+           write write-char zero?)))
+
+  (define geiser-r7rs-small-symbols 
+    (make-parameter
+     '(* + - ... / < <= = => > >= abs and append apply assoc assq
+         assv begin binary-port? boolean=? boolean? bytevector
+         bytevector-append bytevector-copy bytevector-copy! bytevector-length
+         bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
+         call-with-current-continuation call-with-port call-with-values call/cc
+         car case cdar cddr cdr ceiling char->integer char-ready? char<=?
+         char<? char=? char>=? char>? char? close-input-port
+         close-output-port close-port complex? cond cond-expand cons
+         current-error-port current-input-port current-output-port
+         define define-record-type define-syntax define-values denominator do
+         dynamic-wind else eof-object? equal? error error-object-message
+         even? exact-integer-sqrt exact? features floor floor-remainder
+         flush-output-port gcd get-output-string if include-ci inexact?
+         input-port? integer? lcm let let*-values let-values letrec* list
+         list->vector list-ref list-tail make-bytevector make-parameter
+         make-vector max memq min negative? not number->string numerator
+         open-input-bytevector open-output-bytevector or output-port?
+         parameterize peek-u8 positive? quasiquote quotient raise-continuable
+         rationalize read-bytevector! read-error? read-string real? reverse
+         set! set-cdr! string string->number string->utf8 string-append
+         eof-object eq? eqv? error-object-irritants error-object? exact
+         exact-integer? expt file-error? floor-quotient floor/ for-each
+         get-output-bytevector guard include inexact input-port-open?
+         integer->char lambda length let* let-syntax letrec letrec-syntax
+         list->string list-copy list-set! list? make-list make-string map
+         member memv modulo newline null? number? odd? open-input-string
+         open-output-string output-port-open? pair? peek-char port?
+         procedure? quote raise rational? read-bytevector read-char read-line
+         read-u8 remainder round set-car! square string->list string->symbol
+         string->vector string-copy string-copy! string-for-each string-map
+         string-set! string<? string>=? string? symbol->string symbol?
+         syntax-rules truncate truncate-remainder u8-ready? unquote
+         utf8->string vector vector->string vector-copy vector-fill!
+         vector-length vector-ref vector? with-exception-handler write-char
+         write-u8 string-fill! string-length string-ref string<=?
+         string=? string>? substring symbol=? syntax-error textual-port?
+         truncate-quotient truncate/ unless unquote-splicing values
+         vector->list vector-append vector-copy! vector-for-each vector-map
+         vector-set! when write-bytevector write-string zero?)))
+
+  (define geiser-chicken-builtin-symbols 
+    (make-parameter
+     '(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant
+                define-inline define-interface define-record define-record-type define-specialization
+                define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda
+                foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor
+                handle-exceptions import let*-values let-location let-optionals let-optionals*
+                let-values letrec* letrec-values match-letrec module parameterize regex-case
+                require-extension select set! unless use when with-input-from-pipe match
+                match-lambda match-lambda* match-let match-let* receive)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Utilities
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define find-module ##sys#find-module)
+  (define current-module ##sys#current-module)
+  (define switch-module ##sys#switch-module)
+  (define module-name ##sys#module-name)
+  (define (list-modules) (map car ##sys#module-table))
+
+  (define (write-to-log form) #f)
+  (define debug-log (make-parameter #f))
+     
+  (if use-debug-log
+   (begin
+     (define (write-to-log form)
+       (when (not (debug-log))
+         (debug-log (file-open "~/geiser-log.txt" (+ open/wronly open/append open/text open/creat)))
+         (set-file-position! (debug-log) 0 seek/end))
+       (file-write (debug-log) (with-all-output-to-string (lambda () (write form) (newline))))
+       (file-write (debug-log) "\n"))))
+
+  ;; This really should be a chicken library function
+  (define (write-exception exn)
+    (define (write-call-entry call)
+      (let ((type (vector-ref call 0))
+            (line (vector-ref call 1)))
+        (cond
+         ((equal? type "<syntax>")
+          (display (string-append type " ")) (write line) (newline))
+         ((equal? type "<eval>")
+          (display (string-append type "   ")) (write line) (newline)))))
+
+    (display (format "Error: (~s) ~s: ~s"
+                     ((condition-property-accessor 'exn 'location) exn)
+                     ((condition-property-accessor 'exn 'message) exn)
+                     ((condition-property-accessor 'exn 'arguments) exn)))
+    (newline)
+    (display "Call history: ") (newline)
+    (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn))
+    (newline))
+
+  ;; And this should be a chicken library function as well
+  (define (with-all-output-to-string thunk)
+    (with-output-to-string
+      (lambda ()
+        (with-error-output-to-port 
+         (current-output-port)
+         thunk))))
+
+  (define (maybe-call func val)
+    (if val (func val) #f))
+
+  (define (make-apropos-regex prefix)
+    (string-append "^([^#]+#)*" (regexp-escape prefix)))
+
+  (define (describe-symbol sym #!key (exact? #f))
+    (let* ((str (symbol->string sym))
+           (found (apropos-information-list (regexp (make-apropos-regex str)) #:macros? #t)))
+      (if exact?
+          (filter (lambda (v)
+                    (equal? str (string-substitute ".*#([^#]+)" "\\1" (symbol->string (car v)))))
+                  found)
+          found)))
+
+  ;; Wraps output from geiser functions
+  (define (call-with-result module thunk)
+    (let* ((result (if #f #f))
+           (output (if #f #f))
+           (module (maybe-call (lambda (v) (find-module module)) module))
+           (original-module (current-module)))
+
+      (set! output
+            (handle-exceptions exn 
+             (with-all-output-to-string 
+              (lambda () (write-exception exn)))
+             (with-all-output-to-string
+              (lambda () 
+                (switch-module module)
+                (call-with-values thunk (lambda v (set! result v)))))))
+
+      (switch-module original-module)
+
+      (set! result (if (list? result) 
+                       (map (lambda (v) (with-output-to-string (lambda () (write v)))) result)
+                       (list (with-output-to-string (lambda () (write result))))))
+
+      (let ((out-form
+             `((result ,@result)
+               (output . ,output))))
+        (write out-form)
+        (write-to-log out-form))
+
+      (newline)))
+
+  (define geiser-toplevel-functions (make-parameter '()))
+
+  ;; This macro aids in the creation of toplevel definitions for the interpreter which are also available to code
+  ;; toplevel passes parameters via the current-input-port, and so in order to make the definition behave nicely
+  ;; in both usage contexts I defined a (get-arg) function which iteratively pulls arguments either from the 
+  ;; input port or from the variable arguments, depending on context.
+  (define-syntax define-toplevel-for-geiser
+    (lambda (f r c)
+      (let* ((name (cadr f))
+             (body (cddr f)))
+        `(begin
+           (,(r 'define) (,name . !!args)
+            (,(r 'define) !!read-arg (null? !!args))
+            (,(r 'define) (get-arg)
+             (if !!read-arg
+                 (read)
+                 (let ((arg (car !!args)))
+                   (set! !!args (cdr !!args))
+                   arg)))
+            (begin ,@body))
+           (,(r 'geiser-toplevel-functions) (cons (cons ',name ,name) (geiser-toplevel-functions)))))))
+
+  (define (find-standards-with-symbol sym)
+    (append
+     (if (any (cut eq? <> sym) (geiser-r4rs-symbols))
+         '(r4rs)
+         '())
+     (if (any (cut eq? <> sym) (geiser-r5rs-symbols))
+         '(r5rs)
+         '())
+     (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols))
+         '(r7rs)
+         '())
+     (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols))
+         '(chicken)
+         '())))
+  
+  ;; Locates any paths at which a particular symbol might be located
+  (define (find-library-paths sym types)
+    ;; Removes the given sym from the node path
+    (define (remove-self sym path)
+      (cond
+       ((not (list? path)) path)
+       ((null? path) path)
+       ((null? (cdr path))
+        (if (eq? (car path) sym)
+            '()
+            path))
+       (else
+        (cons (car path) (remove-self sym (cdr path))))))
+
+    (append
+     (map
+      (cut list <>)
+      (find-standards-with-symbol sym))
+     (map
+      (lambda (node)
+        (remove-self sym (node-path node))) 
+      (filter 
+       (lambda (n) 
+         (let ((type (node-type n)))
+           (any (cut eq? type <>) types)))
+       (match-nodes sym)))))
+  
+  ;; Builds a signature list from an identifier
+  (define (find-signatures toplevel-module sym)
+    (define str (symbol->string sym))
+
+    (define (make-module-list sym module-sym)
+      (if (null? module-sym)
+          (find-standards-with-symbol sym)
+          (cons module-sym (find-standards-with-symbol sym))))
+    
+    (define (fmt node)
+      (let* ((entry-str (car node))
+             (module (cadr node))
+             (rest (cddr node))
+             (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
+        (cond
+         ((equal? 'macro type)
+          `(,entry-str ("args" (("required" <macro>)
+                                ("optional" ...)
+                                ("key")))
+                       ("module" ,@(make-module-list sym module))))
+         ((or (equal? 'variable type)
+              (equal? 'constant type))
+          (if (null? module)
+              `(,entry-str ("value" . ,(eval sym)))
+              (let* ((original-module (current-module))
+                     (desired-module (find-module (string->symbol module)))
+                     (value (begin (switch-module desired-module)
+                                   (eval sym))))
+                (switch-module original-module)
+                `(,entry-str ("value" . ,value)
+                             ("module" ,@(make-module-list sym module))))))
+         (else
+          (let ((reqs '())
+                (opts '())
+                (keys '())
+                (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+            (define (clean-arg arg)
+              (string->symbol (string-substitute "(.*[^0-9]+)[0-9]+" "\\1" (symbol->string arg))))
+
+            (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
+              (when (not (null? args))
+                (cond
+                 ((or (pair? args) (list? args))
+                  (cond
+                   ((eq? '#!key (car args))
+                    (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
+                   ((eq? '#!optional (car args))
+                    (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
+                   (else
+                    (begin
+                      (cond
+                       (reqs?
+                        (set! reqs (append reqs (list (clean-arg (car args))))))
+                       (opts?
+                        (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
+                       (keys?
+                        (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
+                      (collect-args (cdr args))))))
+                 (else
+                  (set! opts (list (clean-arg args) '...))))))
+
+            (collect-args args)
+
+            `(,entry-str ("args" (("required" ,@reqs)
+                                  ("optional" ,@opts)
+                                  ("key" ,@keys)))
+                         ("module" ,@(make-module-list sym module))))))))
+
+    (define (find sym)
+      (map
+       (lambda (s)
+         ;; Remove egg name and add module
+         (let* ((str (symbol->string (car s)))
+                (name (string-substitute ".*#([^#]+)" "\\1" str))
+                (module
+                    (if (string-search "#" str)
+                        (string-substitute "^([^#]+)#[^#]+$" "\\1" str)
+                        '())))
+           (cons name (cons module (cdr s)))))
+       (describe-symbol sym exact?: #t)))
+
+    (map fmt (find sym)))
+
+  ;; Builds the documentation from Chicken Doc for a specific ymbol
+  (define (make-doc symbol #!optional (filter-for-type #f))
+    (with-output-to-string 
+      (lambda () 
+        (map (lambda (node)
+               (display (string-append "= Node: " (->string (node-id node)) " " " =\n"))
+               (describe node)
+               (display "\n\n")) 
+             (filter 
+              (lambda (n)
+                (or (not filter-for-type)
+                    (eq? (node-type n) filter-for-type)))
+              (match-nodes symbol))))))
+
+  (define (make-geiser-toplevel-bindings)
+    (map
+     (lambda (pair)
+       (toplevel-command (car pair) (cdr pair)))
+     (geiser-toplevel-functions)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Geiser toplevel functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Basically all non-core functions pass through geiser-eval
+
+  (define-toplevel-for-geiser geiser-eval
+    ;; We can't allow nested module definitions in Chicken
+    (define (form-has-module? form)
+      (let ((reg "\\( *module +|\\( *define-library +"))
+        (string-search reg form)))
+
+    ;; Chicken doesn't support calling toplevel functions through eval,
+    ;; So when we're in a module or calling into an environment we have
+    ;; to first call from the toplevel environment and then switch
+    ;; into the desired env.
+    (define (form-has-geiser? form)
+      (let ((reg "\\( *geiser-"))
+        (string-search reg form)))
+
+    ;; All calls start at toplevel
+    (let* ((module (get-arg))
+           (form (get-arg))
+           (str-form (format "~s" form))
+           (is-module? (form-has-module? str-form))
+           (is-geiser? (form-has-geiser? str-form))
+           (host-module (and (not is-module?)
+                             (not is-geiser?)
+                             (any (cut equal? module <>) (list-modules))
+                             module)))
+
+      (when (and module (not (symbol? module)))
+        (error "Module should be a symbol"))
+
+      ;; Inject the desired module as the first parameter
+      (when is-geiser?
+        (let ((module (maybe-call (lambda (v) (symbol->string module)) module)))
+          (set! form (cons (car form) (cons module (cdr form))))))
+
+      (define (thunk)
+        (eval form))
+
+      (write-to-log form)
+
+      (call-with-result host-module thunk)))
+
+  ;; Load a file
+
+  (define-toplevel-for-geiser geiser-load-file 
+    (let* ((file (get-arg))
+           (file (if (symbol? file) (symbol->string file) file))
+           (found-file (geiser-find-file #f file)))
+      (call-with-result #f
+       (lambda ()
+         (when found-file
+           (load found-file))))))
+
+  ;; The no-values identity
+  
+  (define-toplevel-for-geiser geiser-no-values
+    (values))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Miscellaneous
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Invoke a newline
+
+  (define (geiser-newline . rest)
+    (newline))
+
+  ;; Spawn a server for remote repl access
+
+  (define (geiser-start-server . rest)
+    (let* ((listener (tcp-listen 0))
+           (port (tcp-listener-port listener)))
+      (define (remote-repl)
+        (receive (in out) (tcp-accept listener)
+          (current-input-port in)
+          (current-output-port out)
+          (current-error-port out)
+          
+          (repl)))
+
+      (thread-start! (make-thread remote-repl))
+
+      (write-to-log `(geiser-start-server . ,rest))
+      (write-to-log `(port ,port))
+      
+      (write `(port ,port))
+      (newline)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Completions, Autodoc and Signature
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (geiser-completions toplevel-module prefix . rest)
+    ;; We search both toplevel definitions and module definitions
+    (let* ((prefix (if (symbol? prefix) (symbol->string prefix) prefix))
+           (re (regexp (make-apropos-regex prefix))))
+      (sort! (map (lambda (sym)
+                    ;; Strip out everything before the prefix
+                    (string-substitute (string-append ".*(" (regexp-escape prefix) ".*)") "\\1" (symbol->string sym)))
+                  (append (apropos-list re #:macros? #t)
+                          (geiser-module-completions toplevel-module prefix)))
+             string<?)))
+
+  (define (geiser-module-completions toplevel-module prefix . rest)
+    (let* ((match (string-append "^" (regexp-escape prefix))))
+      (filter (lambda (v) (string-search match (symbol->string v)))
+              (list-modules))))
+
+  (define (geiser-autodoc toplevel-module ids . rest) 
+    (define (generate-details sym)
+      (find-signatures toplevel-module sym))
+
+    (if (list? ids)
+        (foldr append '()
+               (map generate-details ids))
+        '()))
+
+  (define (geiser-object-signature toplevel-module name object . rest) 
+    (let* ((sig (geiser-autodoc toplevel-module `(,name))))
+      (if (null? sig) '() (car sig))))
+
+    ;; TODO: Divine some way to support this functionality
+
+  (define (geiser-symbol-location toplevel-module symbol . rest) 
+    '(("file") ("line")))
+
+  (define (geiser-symbol-documentation toplevel-module symbol . rest)
+    (let* ((sig (find-signatures toplevel-module symbol)))
+      `(("signature" ,@(car sig)) 
+        ("docstring" . ,(make-doc symbol)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; File and Buffer Operations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-load-paths (make-parameter '()))
+
+  (define (geiser-find-file toplevel-module file . rest)
+    (let ((paths (append '("" ".") (geiser-load-paths))))
+      (define (try-find file paths)
+        (cond
+         ((null? paths) #f)
+         ((file-exists? (string-append (car paths) file))
+          (string-append (car paths) file))
+         (else (try-find file (cdr paths)))))
+      (try-find file paths)))
+
+  (define (geiser-add-to-load-path toplevel-module directory . rest) 
+    (let* ((directory (if (symbol? directory) 
+                          (symbol->string directory)
+                          directory))
+           (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory 1))))) 
+                          (string-append directory "/")
+                          directory)))
+      (call-with-result #f
+       (lambda ()
+         (when (directory-exists? directory)
+           (geiser-load-paths (cons directory (geiser-load-paths))))))))
+
+  (define (geiser-compile-file toplevel-module file . rest) 
+    (let* ((file (if (symbol? file) (symbol->string file) file))
+           (found-file (geiser-find-file toplevel-module file)))
+      (call-with-result #f
+       (lambda ()
+         (when found-file
+           (compile-file found-file))))))
+
+    ;; TODO: Support compiling regions
+
+  (define (geiser-compile toplevel-module form module . rest) 
+    (error "Chicken does not support compiling regions"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Modules
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Should return:
+  ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) ("vars" . variables))
+  (define (geiser-module-exports toplevel-module module-name . rest) 
+    (let* ((nodes (match-nodes module-name)))
+      (if (null? nodes)
+          '()
+          (let ((mod '())
+                (proc '())
+                (syn '())
+                (var '()))
+            (map
+             (lambda (node)
+               (let ((type (node-type node))
+                     (name (node-id node))
+                     (path (node-path node)))
+                 (cond
+                  ((memq type '(unit egg))
+                   (set! mod (cons name mod)))
+                  ((memq type '(procedure record setter class method))
+                   (set! proc (cons name proc)))
+                  ((memq type '(read syntax))
+                   (set! syn (cons name syn)))
+                  ((memq type '(parameter constant))
+                   (set! var (cons name var))))))
+             nodes)
+            `(("modules" . ,mod)
+              ("proces" . ,proc)
+              ("syntax" . ,syn)
+              ("vars" . ,var))))))
+
+  ;; Returns the path for the file in which an egg or module was defined
+
+  (define (geiser-module-path toplevel-module module-name . rest) 
+    #f)
+
+  ;; Returns:
+  ;; `(("file" . ,(module-path name)) ("line"))
+
+  (define (geiser-module-location toplevel-module name . rest) 
+    #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (geiser-macroexpand toplevel-module form . rest)
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (expand form)))))
+
+;; End module    
+  )
+
+(import geiser)
+(make-geiser-toplevel-bindings)
-- 
cgit v1.2.3