Initial commit

elpa/geiser-20171010.1610/bin/geiser-racket.sh

@@ -0,0 +1,24 @@
+#!/bin/bash
+#|
+topdir=$(dirname $0)
+elpa_scheme=$topdir/scheme
+in_scheme=$topdir/../scheme
+top=$(if [ -d $elpa_scheme ]; then echo $elpa_scheme; else echo $in_scheme; fi)
+exec racket -i -S "$top/racket" -l errortrace -cu "$0" ${1+"$@"}
+|#
+
+#lang racket/base
+
+(require (lib "cmdline.rkt"))
+(require geiser/server)
+
+(define port (make-parameter 0))
+(define host (make-parameter #f (lambda (h) (and (string? h) h))))
+
+(command-line
+ "run-racket.sh" (current-command-line-arguments)
+ (once-each
+  (("-n" "--hostname") n "Network hostname, or #f for all interfaces" (host n))
+  (("-p" "--port") p "Geiser server port" (port (string->number p)))))
+
+(printf "Geiser server running at port ~a~%" (start-geiser (port) (host)))

elpa/geiser-20171010.1610/dir

@@ -0,0 +1,18 @@
+This is the file .../info/dir, which contains the
+topmost node of the Info hierarchy, called (dir)Top.
+The first time you invoke Info you start off looking at this node.
+
+File: dir,	Node: Top	This is the top of the INFO tree
+
+  This (the Directory node) gives a menu of major topics.
+  Typing "q" exits, "?" lists all Info commands, "d" returns here,
+  "h" gives a primer for first-timers,
+  "mEmacs<Return>" visits the Emacs manual, etc.
+
+  In Emacs, you can click mouse button 2 on a menu item or cross reference
+  to select it.
+
+* Menu:
+
+Emacs
+* Geiser: (geiser).             Emacs environment for Scheme hacking.

elpa/geiser-20171010.1610/geiser-autodoc.el

@@ -0,0 +1,243 @@
+;; geiser-autodoc.el -- autodoc mode
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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 Feb 08, 2009 19:44
+
+
+
+(require 'geiser-eval)
+(require 'geiser-syntax)
+(require 'geiser-custom)
+(require 'geiser-base)
+
+(require 'eldoc)
+
+
+;;; Customization:
+
+(defgroup geiser-autodoc nil
+  "Options for displaying autodoc strings in the echo area."
+  :group 'geiser)
+
+(geiser-custom--defface autodoc-current-arg
+  'font-lock-variable-name-face
+  geiser-autodoc "highlighting current argument in autodoc messages")
+
+(geiser-custom--defface autodoc-identifier
+  'font-lock-function-name-face
+  geiser-autodoc "highlighting procedure name in autodoc messages")
+
+(geiser-custom--defcustom geiser-autodoc-delay 0.3
+  "Delay before autodoc messages are fetched and displayed, in seconds."
+  :type 'number
+  :group 'geiser-autodoc)
+
+(geiser-custom--defcustom geiser-autodoc-display-module-p t
+  "Whether to display procedure module in autodoc strings."
+  :type 'boolean
+  :group 'geiser-autodoc)
+
+(geiser-custom--defcustom geiser-autodoc-identifier-format "%s:%s"
+  "Format for displaying module and procedure or variable name, in that order,
+when `geiser-autodoc-display-module-p' is on."
+  :type 'string
+  :group 'geiser-autodoc)
+
+
+;;; Procedure arguments:
+
+(make-variable-buffer-local
+ (defvar geiser-autodoc--cached-signatures nil))
+
+(defsubst geiser-autodoc--clean-cache ()
+  (setq geiser-autodoc--cached-signatures nil))
+
+(defun geiser-autodoc--show-signatures (ret)
+  (let ((res (geiser-eval--retort-result ret))
+        (signs))
+    (when res
+      (dolist (item res)
+        (push (cons (format "%s" (car item)) (cdr item)) signs))
+      (let ((str (geiser-autodoc--autodoc (geiser-syntax--scan-sexps) signs)))
+        (when (not (string-equal str eldoc-last-message))
+          (eldoc-message str)))
+      (setq geiser-autodoc--cached-signatures signs))))
+
+(defun geiser-autodoc--get-signatures (funs)
+  (when funs
+    (let ((m (format "'(%s)" (mapconcat 'identity funs " "))))
+      (geiser-eval--send `(:eval (:ge autodoc (:scm ,m)))
+                         'geiser-autodoc--show-signatures)))
+  (and (or (assoc (car funs) geiser-autodoc--cached-signatures)
+           (assoc (cadr funs) geiser-autodoc--cached-signatures))
+       geiser-autodoc--cached-signatures))
+
+(defun geiser-autodoc--sanitize-args (args)
+  (cond ((null args) nil)
+        ((listp args)
+         (cons (car args) (geiser-autodoc--sanitize-args (cdr args))))
+        (t '("..."))))
+
+(defun geiser-autodoc--format-arg (a)
+  (cond ((and (listp a) (geiser-syntax--keywordp (car a)))
+         (if (and (cdr a) (listp (cdr a)))
+             (format "(#%s %s)" (car a) (geiser-syntax--display (cadr a)))
+           (format "(#%s)" (car a))))
+        (t (geiser-syntax--display a))))
+
+(defun geiser-autodoc--insert-arg-group (args current &optional pos)
+  (when args (insert " "))
+  (dolist (a (geiser-autodoc--sanitize-args args))
+    (let ((p (point)))
+      (insert (geiser-autodoc--format-arg a))
+      (when (or (and (numberp pos)
+                     (numberp current)
+                     (setq current (1+ current))
+                     (= (1+ pos) current))
+                (and (geiser-syntax--keywordp current)
+                     (listp a)
+                     (geiser-syntax--symbol-eq current (car a))))
+        (put-text-property p (point)
+                           'face 'geiser-font-lock-autodoc-current-arg)
+        (setq pos nil current nil)))
+    (insert " "))
+  (when args (backward-char))
+  current)
+
+(defun geiser-autodoc--insert-args (args pos prev)
+  (let ((cpos 1)
+        (reqs (cdr (assoc "required" args)))
+        (opts (mapcar (lambda (a)
+                        (if (and (symbolp a)
+                                 (not (equal (symbol-name a) "...")))
+                            (list a)
+                          a))
+                      (cdr (assoc "optional" args))))
+        (keys (cdr (assoc "key" args))))
+    (setq cpos
+          (geiser-autodoc--insert-arg-group reqs
+                                            cpos
+                                            (and (not (zerop pos)) pos)))
+    (setq cpos (geiser-autodoc--insert-arg-group opts cpos pos))
+    (geiser-autodoc--insert-arg-group keys prev nil)))
+
+(defsubst geiser-autodoc--id-name (proc module)
+  (let ((str (if module
+                 (format geiser-autodoc-identifier-format module proc)
+               (format "%s" proc))))
+    (propertize str 'face 'geiser-font-lock-autodoc-identifier)))
+
+(defun geiser-autodoc--str* (full-signature)
+  (let ((geiser-font-lock-autodoc-current-arg 'default))
+    (geiser-autodoc--str (list (car full-signature)) full-signature)))
+
+(defsubst geiser-autodoc--value-str (proc module value)
+  (let ((name (geiser-autodoc--id-name proc module)))
+    (if value (format "%s => %s" name value) name)))
+
+(defun geiser-autodoc--str (desc signature)
+  (let ((proc (car desc))
+        (args (cdr (assoc "args" signature)))
+        (module (cdr (assoc "module" signature))))
+    (if (not args)
+      (geiser-autodoc--value-str proc module (cdr (assoc "value" signature)))
+      (save-current-buffer
+        (set-buffer (geiser-syntax--font-lock-buffer))
+        (erase-buffer)
+        (insert (format "(%s" (geiser-autodoc--id-name proc module)))
+        (let ((pos (or (cadr desc) 0))
+              (prev (car (cddr desc))))
+          (dolist (a args)
+            (when (not (member a (cdr (member a args))))
+              (geiser-autodoc--insert-args a pos prev)
+              (insert " |"))))
+        (delete-char -2)
+        (insert ")")
+        (buffer-substring (point-min) (point))))))
+
+(defun geiser-autodoc--autodoc (path &optional signs)
+  (let ((signs (or signs (geiser-autodoc--get-signatures (mapcar 'car path))))
+        (p (car path))
+        (s))
+    (while (and p (not s))
+      (unless (setq s (cdr (assoc (car p) signs)))
+        (setq p (car path))
+        (setq path (cdr path))))
+    (when s (geiser-autodoc--str p s))))
+
+
+;;; Autodoc functions:
+
+(make-variable-buffer-local
+ (defvar geiser-autodoc--inhibit-function nil))
+
+(defsubst geiser-autodoc--inhibit ()
+  (and geiser-autodoc--inhibit-function
+       (funcall geiser-autodoc--inhibit-function)))
+
+(defsubst geiser-autodoc--inhibit-autodoc ()
+  (setq geiser-autodoc--inhibit-function (lambda () t)))
+
+(defsubst geiser-autodoc--disinhibit-autodoc ()
+  (setq geiser-autodoc--inhibit-function nil))
+
+(defsubst geiser-autodoc--autodoc-at-point ()
+  (geiser-autodoc--autodoc (geiser-syntax--scan-sexps)))
+
+(defun geiser-autodoc--eldoc-function ()
+  (ignore-errors
+    (when (not (geiser-autodoc--inhibit))
+      (geiser-autodoc--autodoc-at-point))))
+
+(defun geiser-autodoc-show ()
+  "Show the signature or value of the symbol at point in the echo area."
+  (interactive)
+  (message (geiser-autodoc--autodoc-at-point)))
+
+
+;;; Autodoc mode:
+
+(make-variable-buffer-local
+ (defvar geiser-autodoc-mode-string " A"
+   "Modeline indicator for geiser-autodoc-mode"))
+
+(define-minor-mode geiser-autodoc-mode
+  "Toggle Geiser's Autodoc mode.
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When Autodoc mode is enabled, a synopsis of the word at point is
+displayed in the minibuffer."
+  :init-value nil
+  :lighter geiser-autodoc-mode-string
+  :group 'geiser-autodoc
+
+  (set (make-local-variable 'eldoc-documentation-function)
+       (when geiser-autodoc-mode 'geiser-autodoc--eldoc-function))
+  (set (make-local-variable 'eldoc-minor-mode-string) nil)
+  (set (make-local-variable 'eldoc-idle-delay) geiser-autodoc-delay)
+  (eldoc-mode (if geiser-autodoc-mode 1 -1))
+  (when (called-interactively-p nil)
+    (message "Geiser Autodoc %s"
+             (if geiser-autodoc-mode "enabled" "disabled"))))
+
+(defadvice eldoc-display-message-no-interference-p
+  (after geiser-autodoc--message-ok-p)
+  (when geiser-autodoc-mode
+    (setq ad-return-value
+          (and ad-return-value
+               ;; Display arglist only when the minibuffer is
+               ;; inactive, e.g. not on `C-x C-f'. Lifted from slime.
+               (not (active-minibuffer-window)))))
+  ad-return-value)
+
+
+
+(provide 'geiser-autodoc)

elpa/geiser-20171010.1610/geiser-autoloads.el

@@ -0,0 +1,125 @@
+;;; geiser-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+
+;;;### (autoloads nil "geiser" "geiser.el" (23008 50261 100991 628000))
+;;; Generated autoloads from geiser.el
+
+(defconst geiser-elisp-dir (file-name-directory load-file-name) "\
+Directory containing Geiser's Elisp files.")
+
+(defconst geiser-scheme-dir (let ((d (expand-file-name "./scheme/" geiser-elisp-dir))) (if (file-directory-p d) d (expand-file-name "../scheme/" geiser-elisp-dir))) "\
+Directory containing Geiser's Scheme files.")
+
+(when (not (member geiser-elisp-dir load-path)) (add-to-list 'load-path geiser-elisp-dir))
+
+(autoload 'geiser-version "geiser-version" "\
+Echo Geiser's version." t)
+
+(autoload 'geiser-unload "geiser-reload" "\
+Unload all Geiser code." t)
+
+(autoload 'geiser-reload "geiser-reload" "\
+Reload Geiser code." t)
+
+(autoload 'geiser "geiser-repl" "\
+Start a Geiser REPL, or switch to a running one." t)
+
+(autoload 'run-geiser "geiser-repl" "\
+Start a Geiser REPL." t)
+
+(autoload 'geiser-connect "geiser-repl" "\
+Start a Geiser REPL connected to a remote server." t)
+
+(autoload 'geiser-connect-local "geiser-repl" "\
+Start a Geiser REPL connected to a remote server over a Unix-domain socket." t)
+
+(autoload 'switch-to-geiser "geiser-repl" "\
+Switch to a running one Geiser REPL." t)
+
+(autoload 'run-chez "geiser-chez" "\
+Start a Geiser Chez REPL." t)
+
+(autoload 'switch-to-chez "geiser-chez" "\
+Start a Geiser Chez REPL, or switch to a running one." t)
+
+(autoload 'run-guile "geiser-guile" "\
+Start a Geiser Guile REPL." t)
+
+(autoload 'switch-to-guile "geiser-guile" "\
+Start a Geiser Guile REPL, or switch to a running one." t)
+
+(autoload 'connect-to-guile "geiser-guile" "\
+Connect to a remote Geiser Guile REPL." t)
+
+(autoload 'run-racket "geiser-racket" "\
+Start a Geiser Racket REPL." t)
+
+(autoload 'run-gracket "geiser-racket" "\
+Start a Geiser GRacket REPL." t)
+
+(autoload 'switch-to-racket "geiser-racket" "\
+Start a Geiser Racket REPL, or switch to a running one." t)
+
+(autoload 'connect-to-racket "geiser-racket" "\
+Connect to a remote Geiser Racket REPL." t)
+
+(autoload 'run-chicken "geiser-chicken" "\
+Start a Geiser Chicken REPL." t)
+
+(autoload 'switch-to-chicken "geiser-chicken" "\
+Start a Geiser Chicken REPL, or switch to a running one." t)
+
+(autoload 'connect-to-chicken "geiser-chicken" "\
+Connect to a remote Geiser Chicken REPL." t)
+
+(autoload 'run-mit "geiser-mit" "\
+Start a Geiser MIT/GNU Scheme REPL." t)
+
+(autoload 'switch-to-mit "geiser-mit" "\
+Start a Geiser MIT/GNU Scheme REPL, or switch to a running one." t)
+
+(autoload 'run-chibi "geiser-chibi" "\
+Start a Geiser Chibi Scheme REPL." t)
+
+(autoload 'switch-to-chibi "geiser-chibi" "\
+Start a Geiser Chibi Scheme REPL, or switch to a running one." t)
+
+(autoload 'geiser-mode "geiser-mode" "\
+Minor mode adding Geiser REPL interaction to Scheme buffers." t)
+
+(autoload 'turn-on-geiser-mode "geiser-mode" "\
+Enable Geiser's mode (useful in Scheme buffers)." t)
+
+(autoload 'turn-off-geiser-mode "geiser-mode" "\
+Disable Geiser's mode (useful in Scheme buffers)." t)
+
+(autoload 'geiser-mode--maybe-activate "geiser-mode")
+
+(mapc (lambda (group) (custom-add-load group (symbol-name group)) (custom-add-load 'geiser (symbol-name group))) '(geiser geiser-repl geiser-autodoc geiser-doc geiser-debug geiser-faces geiser-mode geiser-guile geiser-image geiser-racket geiser-chicken geiser-chez geiser-chibi geiser-mit geiser-implementation geiser-xref))
+
+(add-hook 'scheme-mode-hook 'geiser-mode--maybe-activate)
+
+(add-to-list 'auto-mode-alist '("\\.rkt\\'" . scheme-mode))
+
+;;;***
+
+;;;### (autoloads nil nil ("geiser-autodoc.el" "geiser-base.el" "geiser-chez.el"
+;;;;;;  "geiser-chibi.el" "geiser-chicken.el" "geiser-company.el"
+;;;;;;  "geiser-compile.el" "geiser-completion.el" "geiser-connection.el"
+;;;;;;  "geiser-custom.el" "geiser-debug.el" "geiser-doc.el" "geiser-edit.el"
+;;;;;;  "geiser-eval.el" "geiser-guile.el" "geiser-image.el" "geiser-impl.el"
+;;;;;;  "geiser-log.el" "geiser-menu.el" "geiser-mit.el" "geiser-mode.el"
+;;;;;;  "geiser-pkg.el" "geiser-popup.el" "geiser-racket.el" "geiser-reload.el"
+;;;;;;  "geiser-repl.el" "geiser-syntax.el" "geiser-table.el" "geiser-version.el"
+;;;;;;  "geiser-xref.el") (23008 50261 420992 103000))
+
+;;;***
+
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; geiser-autoloads.el ends here

elpa/geiser-20171010.1610/geiser-base.el

@@ -0,0 +1,85 @@
+;;; geiser-base.el --- shared bits
+
+;; Copyright (C) 2009, 2010, 2012, 2013, 2015, 2016  Jose Antonio Ortega Ruiz
+
+;; 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>.
+
+;; Settings and vars shared by all geiser modules, including little
+;; utilities and emacsen compatibility bits.
+
+;;; Emacs compatibility:
+
+(require 'ring)
+
+(eval-after-load "ring"
+  '(when (not (fboundp 'ring-member))
+     (defun ring-member (ring item)
+       (catch 'found
+         (dotimes (ind (ring-length ring) nil)
+           (when (equal item (ring-ref ring ind))
+             (throw 'found ind)))))))
+
+(when (not (fboundp 'looking-at-p))
+  (defsubst looking-at-p (regexp)
+    (let ((inhibit-changing-match-data t))
+      (looking-at regexp))))
+
+;;; Utilities:
+
+(defsubst geiser--chomp (str)
+  (if (string-match-p ".*\n$" str) (substring str 0 -1) str))
+
+(defun geiser--shorten-str (str len &optional sep)
+  (let ((str-len (length str)))
+    (if (<= str-len len)
+        str
+      (let* ((sep (or sep " ... "))
+             (sep-len (length sep))
+             (prefix-len (/ (- str-len sep-len) 2))
+             (prefix (substring str 0 prefix-len))
+             (suffix (substring str (- str-len prefix-len))))
+        (format "%s%s%s" prefix sep suffix)))))
+
+(defun geiser--region-to-string (begin &optional end)
+  (let ((end (or end (point))))
+    (when (< begin end)
+      (let* ((str (buffer-substring-no-properties begin end))
+             (pieces (split-string str nil t)))
+        (mapconcat 'identity pieces " ")))))
+
+(defun geiser--insert-with-face (str face)
+  (let ((p (point)))
+    (insert str)
+    (put-text-property p (point) 'face face)))
+
+
+(defmacro geiser--save-msg (&rest body)
+  (let ((msg (make-symbol "msg")))
+    `(let ((,msg (current-message)))
+       ,@body
+       (message ,msg))))
+
+(put 'geiser--save-msg 'lisp-indent-function 0)
+
+(defun geiser--del-dups (lst)
+  (let (result)
+    (dolist (e lst (nreverse result))
+      (unless (member e result) (push e result)))))
+
+(defsubst geiser--symbol-at-point ()
+  (let ((thing (thing-at-point 'symbol)))
+    (and thing (make-symbol thing))))
+
+(defun geiser--cut-version (v)
+  (when (string-match "\\([0-9]+\\(?:\\.[0-9]+\\)*\\).*" v)
+    (match-string 1 v)))
+
+(defun geiser--version< (v1 v2)
+  (let ((v1 (geiser--cut-version v1))
+        (v2 (geiser--cut-version v2)))
+    (and v1 v2 (version< v1 v2))))
+
+(provide 'geiser-base)

elpa/geiser-20171010.1610/geiser-chez.el

@@ -0,0 +1,136 @@
+;; geiser-chez.el -- Chez 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-chez nil
+  "Customization for Geiser's Chez Scheme flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-chez-binary
+    "scheme"
+  "Name to use to call the Chez Scheme executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-chez)
+
+
+;;; REPL support:
+
+(defun geiser-chez--binary ()
+  (if (listp geiser-chez-binary)
+      (car geiser-chez-binary)
+    geiser-chez-binary))
+
+(defun geiser-chez--parameters ()
+  "Return a list with all parameters needed to start Chez Scheme.
+This function uses `geiser-chez-init-file' if it exists."
+  `(,(expand-file-name "chez/geiser/geiser.ss" geiser-scheme-dir))
+  )
+
+(defconst geiser-chez--prompt-regexp "> ")
+
+
+;;; Evaluation support:
+
+(defun geiser-chez--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)))))
+
+(defun geiser-chez--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-chez--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-chez--import-command (module)
+  (format "(import %s)" module))
+
+(defun geiser-chez--exit-command () "(exit 0)")
+;; 
+;; ;;; REPL startup
+
+(defconst geiser-chez-minimum-version "9.4")
+
+(defun geiser-chez--version (binary)
+  (car (process-lines binary "--version")))
+
+(defun geiser-chez--startup (remote)
+  (let ((geiser-log-verbose-p t))
+    (compilation-setup t)
+    (geiser-eval--send/wait "(begin (import (geiser)) (write `((result ) (output . \"\"))) (newline))")))
+
+(defun geiser-chez--display-error (module key msg)
+  (and key (message key) nil))
+
+;;; Implementation definition:
+
+(define-geiser-implementation chez
+  (binary geiser-chez--binary)
+  (arglist geiser-chez--parameters)
+  (version-command geiser-chez--version)
+  (minimum-version geiser-chez-minimum-version)
+  (repl-startup geiser-chez--startup)
+  (prompt-regexp geiser-chez--prompt-regexp)
+  (debugger-prompt-regexp nil) ;; geiser-chez--debugger-prompt-regexp
+  ;; (enter-debugger geiser-chez--enter-debugger)
+  (marshall-procedure geiser-chez--geiser-procedure)
+  (find-module geiser-chez--get-module)
+  ;; (enter-command geiser-chez--enter-command)
+  (exit-command geiser-chez--exit-command)
+  (import-command geiser-chez--import-command)
+  (find-symbol-begin geiser-chez--symbol-begin)
+  (display-error geiser-chez--display-error)
+  ;; (external-help geiser-chez--manual-look-up)
+  ;; (check-buffer geiser-chez--guess)
+  ;; (keywords geiser-chez--keywords)
+  ;; (case-sensitive geiser-chez-case-sensitive-p)
+  )
+
+(geiser-impl--add-to-alist 'regexp "\\.ss$" 'chez t)
+(geiser-impl--add-to-alist 'regexp "\\.def$" 'chez t)
+
+(provide 'geiser-chez)

elpa/geiser-20171010.1610/geiser-chibi.el

@@ -0,0 +1,137 @@
+;; 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."
+  `("-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)))))
+
+(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--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
+           (car (process-lines binary "-V"))
+           " ")))
+
+(defun geiser-chibi--startup (remote)
+  (let ((geiser-log-verbose-p t))
+    (compilation-setup t)
+    ))
+
+;;; 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)
+  )
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'chibi t)
+(geiser-impl--add-to-alist 'regexp "\\.sld$" 'chibi t)
+
+(provide 'geiser-chibi)
+

elpa/geiser-20171010.1610/geiser-chicken.el

@@ -0,0 +1,331 @@
+;; geiser-chicken.el -- chicken's implementation of the geiser protocols
+
+;; Copyright (C) 2014, 2015 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
+  '("assume"
+    "compiler-typecase"
+    "cond-expand"
+    "condition-case"
+    "declare"
+    "define-constant"
+    "define-inline"
+    "define-interface"
+    "define-record"
+    "define-specialization"
+    "define-type"
+    "dotimes"
+    "ecase"
+    "fluid-let"
+    "foreign-lambda"
+    "foreign-lambda*"
+    "foreign-primitive"
+    "foreign-safe-lambda"
+    "foreign-safe-lambda*"
+    "functor"
+    "handle-exceptions"
+    "let-location"
+    "let-optionals"
+    "let-optionals*"
+    "letrec-values"
+    "module"
+    "regex-case"
+    "select"
+    "use"
+    "with-input-from-pipe"))
+
+
+;;; 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" "-:c"))
+        ((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)
+
+(geiser-custom--defcustom geiser-chicken-match-limit 20
+  "The limit on the number of matching symbols that Chicken will provide to Geiser."
+  :type 'integer
+  :group 'geiser-chicken)
+
+(defvar geiser-chicken--required-modules
+  (list "chicken-doc" "apropos" "data-structures" "extras" "ports" "posix" "srfi-1" "srfi-13" "srfi-14" "srfi-18" "srfi-69" "tcp" "utils"))
+
+
+;;; 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))
+    ,@(apply 'append (mapcar (lambda (m) (list "-R" m))
+			     geiser-chicken--required-modules)))))
+
+(defconst geiser-chicken--prompt-regexp "#[^;]*;[^:0-9]*:?[0-9]+> ")
+
+
+;;; Evaluation support:
+
+(defun geiser-chicken--geiser-procedure (proc &rest args)
+  (case proc
+    ((eval compile)
+     (let ((form (mapconcat 'identity (cdr args) " "))
+	   (module (if (car args) (concat "'" (car args)) "#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-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)
+  (if module
+      (max (save-excursion (beginning-of-line) (point))
+	   (save-excursion (skip-syntax-backward "^(>") (1- (point))))
+    (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 ()
+  (append
+   (geiser-syntax--simple-keywords geiser-chicken-extra-keywords)
+   (geiser-syntax--simple-keywords geiser-chicken-builtin-keywords)))
+
+(geiser-syntax--scheme-indent
+ (assume 1)
+ (compiler-typecase 1)
+ (cond-expand 0)
+ (condition-case 1)
+ (cut 1)
+ (cute 1)
+ (declare 0)
+ (dotimes 1)
+ (ecase 1)
+ (fluid-let 1)
+ (foreign-lambda 2)
+ (foreign-lambda* 2)
+ (foreign-primitive 2)
+ (foreign-safe-lambda 2)
+ (foreign-safe-lambda* 2)
+ (functor 3)
+ (handle-exceptions 2)
+ (import 0)
+ (let-location 1)
+ (let-optionals 2)
+ (let-optionals* 2)
+ (letrec-values 1)
+ (module 2)
+ (regex-case 1)
+ (select 1)
+ (set! 1)
+ (use 0)
+ (with-input-from-pipe 1)
+ (with-output-to-pipe 1))
+
+
+;;; REPL startup
+
+(defconst geiser-chicken-minimum-version "4.8.0.0")
+
+(defun geiser-chicken--version (binary)
+  (car (process-lines binary "-e" "(display (chicken-version))")))
+
+(defun connect-to-chicken ()
+  "Start a Chicken REPL connected to a remote process."
+  (interactive)
+  (geiser-connect 'chicken))
+
+(defun geiser-chicken--compile-or-load (force-load)
+  (let ((target
+         (expand-file-name "chicken/geiser/emacs.so" geiser-scheme-dir))
+        (source
+         (expand-file-name "chicken/geiser/emacs.scm" geiser-scheme-dir))
+        (force-load (or force-load (eq system-type 'windows-nt)))
+        (suppression-prefix
+         "(define geiser-stdout (current-output-port))(current-output-port (make-output-port (lambda a #f) (lambda a #f)))")
+        (suppression-postfix
+         "(current-output-port geiser-stdout)")
+	(match-limit-set
+	 (format "(geiser-chicken-symbol-match-limit %s)" geiser-chicken-match-limit)))
+    (let ((load-sequence
+           (cond
+            (force-load
+             (format "(load \"%s\")\n(import geiser)%s\n" source match-limit-set))
+            ((file-exists-p target)
+             (format "%s(load \"%s\")(import geiser)%s%s\n"
+                     suppression-prefix target match-limit-set suppression-postfix))
+            (t
+             (format "%s(use utils)(compile-file \"%s\" options: '(\"-O3\" \"-s\") output-file: \"%s\" load: #t)(import geiser)%s%s\n"
+                     suppression-prefix source target match-limit-set suppression-postfix)))))
+      (geiser-eval--send/wait load-sequence))))
+
+(defun geiser-chicken--startup (remote)
+  (compilation-setup t)
+  (geiser-chicken--compile-or-load t))
+
+
+;;; 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)

elpa/geiser-20171010.1610/geiser-company.el

@@ -0,0 +1,137 @@
+;; geiser-company.el -- integration with company-mode
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2016 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Aug 24, 2009 12:44
+
+
+
+(require 'geiser-autodoc)
+(require 'geiser-completion)
+(require 'geiser-edit)
+(require 'geiser-base)
+(require 'geiser-doc)
+
+(eval-when-compile (require 'cl))
+
+
+;;; Helpers:
+
+(make-variable-buffer-local
+ (defvar geiser-company--enabled-flag nil))
+
+(make-variable-buffer-local
+ (defvar geiser-company--autodoc-flag nil))
+
+(make-variable-buffer-local
+ (defvar geiser-company--completions nil))
+
+(defun geiser-company--candidates (prefix)
+  (and (equal prefix (car geiser-company--completions))
+       (cdr geiser-company--completions)))
+
+(defun geiser-company--doc (id)
+  (ignore-errors
+    (when (not (geiser-autodoc--inhibit))
+      (let ((help (geiser-autodoc--autodoc `((,id 0)))))
+        (and help (substring-no-properties help))))))
+
+(defun geiser-company--doc-buffer (id)
+  (let* ((impl geiser-impl--implementation)
+         (module (geiser-doc-module (geiser-eval--get-module) impl))
+         (symbol (make-symbol id))
+         (ds (geiser-doc--get-docstring symbol module)))
+    (if (or (not ds) (not (listp ds)))
+        (message "No documentation available for '%s'" symbol)
+      (with-current-buffer (get-buffer-create "*company-documentation*")
+        (geiser-doc--render-docstring ds symbol module impl)
+        (current-buffer)))))
+
+(defun geiser-company--location (id)
+  (ignore-errors
+    (when (not (geiser-autodoc--inhibit))
+      (let ((id (make-symbol id)))
+        (condition-case nil
+            (geiser-edit-module id 'noselect)
+          (error (geiser-edit-symbol id 'noselect)))))))
+
+(defun geiser-company--prefix-at-point ()
+  (ignore-errors
+    (when (and (not (geiser-autodoc--inhibit)) geiser-company--enabled-flag)
+      (if (nth 8 (syntax-ppss)) 'stop
+        (let* ((prefix (and (looking-at-p "\\_>")
+                            (geiser-completion--prefix nil)))
+               (cmps1 (and prefix
+                           (geiser-completion--complete prefix nil)))
+               (cmps2 (and prefix
+                           (geiser-completion--complete prefix t)))
+               (mprefix (and (not cmps1) (not cmps2)
+                             (geiser-completion--prefix t)))
+               (cmps3 (and mprefix (geiser-completion--complete mprefix t)))
+               (cmps (or cmps3 (append cmps1 cmps2)))
+               (prefix (or mprefix prefix)))
+          (setq geiser-company--completions (cons prefix cmps))
+          prefix)))))
+
+
+;;; Activation
+
+(defun geiser-company--setup (enable)
+  (setq geiser-company--enabled-flag enable)
+  (when (fboundp 'geiser-company--setup-company)
+    (geiser-company--setup-company enable)))
+
+(defun geiser-company--inhibit-autodoc (ignored)
+  (when (setq geiser-company--autodoc-flag geiser-autodoc-mode)
+    (geiser-autodoc-mode -1)))
+
+(defun geiser-company--restore-autodoc (&optional ignored)
+  (when geiser-company--autodoc-flag
+    (geiser-autodoc-mode 1)))
+
+
+;;; Company activation
+
+(declare-function company-begin-backend "ext:company")
+(declare-function company-cancel "ext:company")
+(declare-function company-mode "ext:company")
+(defvar company-backends)
+(defvar company-active-map)
+(eval-after-load "company"
+  '(progn
+     (defun geiser-company-backend (command &optional arg &rest ignored)
+       "A `company-mode' completion back-end for `geiser-mode'."
+       (interactive (list 'interactive))
+       (case command
+         ('interactive (company-begin-backend 'geiser-company-backend))
+         ('prefix (geiser-company--prefix-at-point))
+         ('candidates (geiser-company--candidates arg))
+         ('meta (geiser-company--doc arg))
+         ('doc-buffer (geiser-company--doc-buffer arg))
+         ('location (geiser-company--location arg))
+         ('sorted t)))
+     (defun geiser-company--setup-company (enable)
+       (when enable
+	 (set (make-local-variable 'company-backends)
+	      (add-to-list 'company-backends 'geiser-company-backend)))
+       (company-mode (if enable 1 -1)))
+     (add-hook 'company-completion-finished-hook
+               'geiser-company--restore-autodoc)
+     (add-hook 'company-completion-cancelled-hook
+               'geiser-company--restore-autodoc)
+     (add-hook 'company-completion-started-hook
+               'geiser-company--inhibit-autodoc)
+     (define-key company-active-map (kbd "M-`")
+       (lambda ()
+         (interactive)
+         (company-cancel)
+         (call-interactively 'geiser-completion--complete-module)))))
+
+
+
+(provide 'geiser-company)

elpa/geiser-20171010.1610/geiser-compile.el

@@ -0,0 +1,79 @@
+;; geiser-compile.el -- compile/load scheme files
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016 Jose Antonio Ortega Ruiz
+
+;; 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: Wed Feb 11, 2009 00:16
+
+
+
+(require 'geiser-debug)
+(require 'geiser-autodoc)
+(require 'geiser-eval)
+(require 'geiser-base)
+
+
+;;; Auxiliary functions:
+
+(defun geiser-compile--buffer/path (&optional path)
+  (let ((path (or path (read-file-name "Scheme file: " nil nil t))))
+    (let ((buffer (find-file-noselect path)))
+      (when (and (buffer-modified-p buffer)
+                 (y-or-n-p "Save buffer? "))
+        (save-buffer buffer))
+      (cons buffer path))))
+
+(defun geiser-compile--display-result (title ret)
+  (if (not (geiser-eval--retort-error ret))
+      (message "%s done" title)
+    (message ""))
+  (geiser-debug--display-retort title ret))
+
+(defun geiser-compile--file-op (path compile-p msg)
+  (let* ((b/p (geiser-compile--buffer/path path))
+         (buffer (car b/p))
+         (path (cdr b/p))
+         (msg (format "%s %s ..." msg path))
+         (code `(,(if compile-p :comp-file :load-file) ,path)))
+    (message msg)
+    (geiser-autodoc--clean-cache)
+    (geiser-compile--display-result msg (geiser-eval--send/wait code))))
+
+
+;;; User commands:
+
+(defun geiser-compile-file (path)
+  "Compile and load Scheme file."
+  (interactive "FScheme file: ")
+  (geiser-compile--file-op path t "Compiling"))
+
+(defun geiser-compile-current-buffer ()
+  "Compile and load current Scheme file."
+  (interactive)
+  (geiser-compile-file (buffer-file-name (current-buffer))))
+
+(defun geiser-load-file (path)
+  "Load Scheme file."
+  (interactive "FScheme file: ")
+  (geiser-compile--file-op (expand-file-name path) nil "Loading"))
+
+(defun geiser-load-current-buffer ()
+  "Load current Scheme file."
+  (interactive)
+  (geiser-load-file (buffer-file-name (current-buffer))))
+
+(defun geiser-add-to-load-path (path)
+  "Add a new directory to running Scheme's load path.
+When called interactively, this function will ask for the path to
+add, defaulting to the current buffer's directory."
+  (interactive "DDirectory to add: ")
+  (let* ((c `(:eval (:ge add-to-load-path ,(expand-file-name path))))
+         (r (geiser-eval--send/result c)))
+    (message "%s" (if r "Added" "Failed!"))))
+
+
+(provide 'geiser-compile)

elpa/geiser-20171010.1610/geiser-completion.el

@@ -0,0 +1,195 @@
+;;; geiser-completion.el -- tab completion
+
+;; Copyright (C) 2009, 2010, 2011, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Feb 09, 2009 22:21
+
+
+
+(require 'geiser-impl)
+(require 'geiser-eval)
+(require 'geiser-log)
+(require 'geiser-syntax)
+(require 'geiser-base)
+
+(require 'comint)
+(require 'minibuffer)
+
+
+;;; Minibuffer maps:
+
+(defvar geiser-completion--minibuffer-map
+  (let ((map (make-keymap)))
+    (set-keymap-parent map minibuffer-local-completion-map)
+    (define-key map "?" 'self-insert-command)
+    map))
+
+(defvar geiser-completion--module-minibuffer-map
+  (let ((map (make-keymap)))
+    (set-keymap-parent map minibuffer-local-completion-map)
+    (define-key map " " 'self-insert-command)
+    (define-key map "?" 'self-insert-command)
+    map))
+
+
+;;; Completion functionality:
+
+(defvar geiser-completion--binding-forms nil)
+(geiser-impl--register-local-variable
+ 'geiser-completion--binding-forms 'binding-forms nil
+ "A list of forms introducing local bindings, a la let or lambda.")
+
+(defvar geiser-completion--binding-forms* nil)
+(geiser-impl--register-local-variable
+ 'geiser-completion--binding-forms* 'binding-forms* nil
+ "A list of forms introducing nested local bindings, a la let*.")
+
+(defsubst geiser-completion--locals ()
+  (geiser-syntax--locals-around-point geiser-completion--binding-forms
+                                      geiser-completion--binding-forms*))
+
+(defun geiser-completion--symbol-list (prefix)
+  (geiser--del-dups
+   (append (all-completions prefix (geiser-completion--locals))
+           (geiser-eval--send/result `(:eval (:ge completions ,prefix))))))
+
+(defsubst geiser-completion--module-list (prefix)
+  (geiser-eval--send/result `(:eval (:ge module-completions ,prefix))))
+
+(defvar geiser-completion--symbol-list-func
+  (completion-table-dynamic 'geiser-completion--symbol-list))
+
+(defvar geiser-completion--module-list-func
+  (completion-table-dynamic 'geiser-completion--module-list))
+
+(defun geiser-completion--complete (prefix modules)
+  (if modules (geiser-completion--module-list prefix)
+    (geiser-completion--symbol-list prefix)))
+
+(defvar geiser-completion--symbol-history nil)
+
+(defun geiser-completion--read-symbol (prompt &optional default history)
+  (let ((minibuffer-local-completion-map geiser-completion--minibuffer-map))
+    (make-symbol (completing-read prompt
+                                  geiser-completion--symbol-list-func
+                                  nil nil nil
+                                  (or history
+                                      geiser-completion--symbol-history)
+                                  (or default (geiser--symbol-at-point))))))
+
+(defvar geiser-completion--module-history nil)
+
+(defun geiser-completion--read-module (&optional prompt default history)
+  (let ((minibuffer-local-completion-map
+         geiser-completion--module-minibuffer-map))
+    (completing-read (or prompt "Module name: ")
+                     geiser-completion--module-list-func
+                     nil nil nil
+                     (or history geiser-completion--module-history)
+                     default)))
+
+(defvar geiser-completion--symbol-begin-function nil)
+
+(defun geiser-completion--def-symbol-begin (module)
+  (save-excursion (skip-syntax-backward "^-()>") (point)))
+
+(geiser-impl--register-local-method
+ 'geiser-completion--symbol-begin-function 'find-symbol-begin
+ 'geiser-completion--def-symbol-begin
+ "An optional function finding the position of the beginning of
+the identifier around point. Takes a boolean, indicating whether
+we're looking for a module name.")
+
+(defun geiser-completion--symbol-begin (module)
+  (funcall geiser-completion--symbol-begin-function module))
+
+(defun geiser-completion--module-at-point ()
+  (save-excursion
+    (goto-char (geiser-completion--symbol-begin t))
+    (ignore-errors (thing-at-point 'sexp))))
+
+(defsubst geiser-completion--prefix (module)
+  (buffer-substring-no-properties (geiser-completion--symbol-begin module)
+                                  (point)))
+
+(defsubst geiser-completion--prefix-end (beg mod)
+  (unless (or (eq beg (point-max))
+              (member (char-syntax (char-after beg))
+                      (if mod '(?\" ?\)) '(?\" ?\( ?\)))))
+    (let ((pos (point)))
+      (condition-case nil
+          (save-excursion
+            (goto-char beg)
+            (forward-sexp 1)
+            (when (>= (point) pos)
+              (point)))
+        (scan-error pos)))))
+
+(defun geiser-completion--thing-at-point (module &optional predicate)
+  (with-syntax-table scheme-mode-syntax-table
+    (let* ((beg (geiser-completion--symbol-begin module))
+           (end (or (geiser-completion--prefix-end beg module) beg))
+           (prefix (and (> end beg) (buffer-substring-no-properties beg end)))
+           (prefix (and prefix
+                        (if (string-match "\\([^-]+\\)-" prefix)
+                            (match-string 1 prefix)
+                          prefix)))
+           (cmps (and prefix (geiser-completion--complete prefix module))))
+      (and cmps (list beg end cmps)))))
+
+(defun geiser-completion--for-symbol (&optional predicate)
+  (geiser-completion--thing-at-point nil predicate))
+
+(defun geiser-completion--for-module (&optional predicate)
+  (geiser-completion--thing-at-point t predicate))
+
+(defun geiser-completion--for-filename ()
+  (when (geiser-syntax--in-string-p)
+    (let ((comint-completion-addsuffix "\""))
+      (comint-dynamic-complete-filename))))
+
+(defun geiser-completion--setup (enable)
+  (set (make-local-variable 'completion-at-point-functions)
+       (if enable
+           '(geiser-completion--for-symbol
+             geiser-completion--for-module
+             geiser-completion--for-filename)
+         (default-value 'completion-at-point-functions))))
+
+(defun geiser-completion--complete-module ()
+  "Complete module name at point."
+  (interactive)
+  (let ((completion-at-point-functions '(geiser-completion--for-module)))
+    (call-interactively 'completion-at-point)))
+
+
+;;; Smart tab mode:
+
+(make-variable-buffer-local
+ (defvar geiser-smart-tab-mode-string " SmartTab"
+   "Modeline indicator for geiser-smart-tab-mode"))
+
+(define-minor-mode geiser-smart-tab-mode
+  "Toggle smart tab mode.
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When this mode is enable, TAB will indent if at point is at
+beginning of line or after a white space or closing parenthesis,
+and will try completing symbol at point otherwise."
+  :init-value nil
+  :lighter geiser-smart-tab-mode-string
+  :group 'geiser-mode
+  (set (make-local-variable 'tab-always-indent)
+       (if geiser-smart-tab-mode
+           'complete
+         (default-value 'tab-always-indent))))
+
+
+(provide 'geiser-completion)

elpa/geiser-20171010.1610/geiser-connection.el

@@ -0,0 +1,269 @@
+;;; geiser-connection.el -- talking to a scheme process
+
+;; Copyright (C) 2009, 2010, 2011, 2013 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Feb 07, 2009 21:11
+
+
+
+;; Connection datatype and functions for managing request queues
+;; between emacs and inferior guile processes.
+
+(require 'geiser-log)
+(require 'geiser-syntax)
+(require 'geiser-base)
+(require 'geiser-impl)
+
+(require 'tq)
+
+
+;;; Buffer connections:
+
+(make-variable-buffer-local
+ (defvar geiser-con--connection nil))
+
+(defun geiser-con--get-connection (buffer/proc)
+  (if (processp buffer/proc)
+      (geiser-con--get-connection (process-buffer buffer/proc))
+    (with-current-buffer buffer/proc geiser-con--connection)))
+
+
+;;; Request datatype:
+
+(defun geiser-con--make-request (con str cont &optional sender-buffer)
+  (list (cons :id (geiser-con--connection-inc-count con))
+        (cons :string str)
+        (cons :continuation cont)
+        (cons :buffer (or sender-buffer (current-buffer)))
+        (cons :connection con)))
+
+(defsubst geiser-con--request-id (req)
+  (cdr (assq :id req)))
+
+(defsubst geiser-con--request-string (req)
+  (cdr (assq :string req)))
+
+(defsubst geiser-con--request-continuation (req)
+  (cdr (assq :continuation req)))
+
+(defsubst geiser-con--request-buffer (req)
+  (cdr (assq :buffer req)))
+
+(defsubst geiser-con--request-connection (req)
+  (cdr (assq :connection req)))
+
+(defsubst geiser-con--request-deactivate (req)
+  (setcdr (assq :continuation req) nil))
+
+(defsubst geiser-con--request-deactivated-p (req)
+  (null (cdr (assq :continuation req))))
+
+
+;;; Connection datatype:
+
+(defun geiser-con--tq-create (process)
+  (let ((tq (tq-create process)))
+    (set-process-filter process
+			`(lambda (p s) (geiser-con--tq-filter ',tq s)))
+    tq))
+
+(defun geiser-con--tq-filter (tq in)
+  (when (buffer-live-p (tq-buffer tq))
+    (with-current-buffer (tq-buffer tq)
+      (if (tq-queue-empty tq)
+          (progn (geiser-log--error "Unexpected queue input:\n %s" in)
+                 (delete-region (point-min) (point-max)))
+        (goto-char (point-max))
+        (insert in)
+        (goto-char (point-min))
+        (when (re-search-forward (tq-queue-head-regexp tq) nil t)
+          (unwind-protect
+              (funcall (tq-queue-head-fn tq)
+                       (tq-queue-head-closure tq)
+                       (buffer-substring (point-min) (point)))
+            (delete-region (point-min) (point-max))
+            (tq-queue-pop tq)))))))
+
+(defun geiser-con--combined-prompt (prompt debug)
+  (format "\\(%s%s\\)" prompt (if debug (format "\\|%s" debug) "")))
+
+(defun geiser-con--connection-eot-re (prompt debug)
+  (geiser-con--combined-prompt (format "\n%s" prompt)
+                               (and debug (format "\n%s" debug))))
+
+(defun geiser-con--make-connection (proc prompt debug-prompt)
+  (list t
+        (cons :filter (process-filter proc))
+        (cons :tq (geiser-con--tq-create proc))
+        (cons :tq-filter (process-filter proc))
+        (cons :eot (geiser-con--connection-eot-re prompt debug-prompt))
+        (cons :prompt prompt)
+        (cons :debug-prompt debug-prompt)
+        (cons :is-debugging nil)
+        (cons :count 0)
+        (cons :completed (make-hash-table :weakness 'value))))
+
+(defsubst geiser-con--connection-process (c)
+  (tq-process (cdr (assq :tq c))))
+
+(defsubst geiser-con--connection-filter (c)
+  (cdr (assq :filter c)))
+
+(defsubst geiser-con--connection-tq-filter (c)
+  (cdr (assq :tq-filter c)))
+
+(defsubst geiser-con--connection-tq (c)
+  (cdr (assq :tq c)))
+
+(defsubst geiser-con--connection-eot (c)
+  (cdr (assq :eot c)))
+
+(defsubst geiser-con--connection-prompt (c)
+  (cdr (assq :prompt c)))
+
+(defsubst geiser-con--connection-debug-prompt (c)
+  (cdr (assq :debug-prompt c)))
+
+(defsubst geiser-con--connection-is-debugging (c)
+  (cdr (assq :is-debugging c)))
+
+(defsubst geiser-con--connection-set-debugging (c d)
+  (setcdr (assq :is-debugging c) d))
+
+(defun geiser-con--connection-update-debugging (c txt)
+  (let* ((dp (geiser-con--connection-debug-prompt c))
+         (is-d (and (stringp dp) (string-match dp txt))))
+    (geiser-con--connection-set-debugging c is-d)
+    is-d))
+
+(defsubst geiser-con--connection-completed (c r)
+  (geiser-con--request-deactivate r)
+  (puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
+
+(defsubst geiser-con--connection-completed-p (c id)
+  (gethash id (cdr (assoc :completed c))))
+
+(defun geiser-con--connection-inc-count (c)
+  (let* ((cnt (assoc :count c))
+         (new (1+ (cdr cnt))))
+    (setcdr cnt new)
+    new))
+
+(defun geiser-con--has-entered-debugger (con answer)
+  (and (not (geiser-con--connection-is-debugging con))
+       (let ((p (car (last (split-string answer "\n" t)))))
+         (and p (geiser-con--connection-update-debugging con p)))))
+
+(defun geiser-con--connection-eot-p (con txt)
+  (and txt
+       (string-match-p (geiser-con--connection-eot con) txt)))
+
+(defun geiser-con--connection-close (con)
+  (let ((tq (geiser-con--connection-tq con)))
+    (and tq (tq-close tq))))
+
+(defvar geiser-con--startup-prompt nil)
+(defun geiser-con--startup-prompt (p s)
+  (setq geiser-con--startup-prompt
+        (concat geiser-con--startup-prompt s))
+  nil)
+
+(defun geiser-con--connection-deactivate (c &optional no-wait)
+  (when (car c)
+    (let* ((tq (geiser-con--connection-tq c))
+           (proc (geiser-con--connection-process c))
+           (proc-filter (geiser-con--connection-filter c)))
+      (unless no-wait
+        (while (and (not (tq-queue-empty tq))
+                    (accept-process-output proc 0.1))))
+      (set-process-filter proc proc-filter)
+      (setcar c nil))))
+
+(defun geiser-con--connection-activate (c)
+  (when (not (car c))
+    (let* ((tq (geiser-con--connection-tq c))
+           (proc (geiser-con--connection-process c))
+           (tq-filter (geiser-con--connection-tq-filter c)))
+      (while (accept-process-output proc 0.01))
+      (set-process-filter proc tq-filter)
+      (setcar c t))))
+
+
+;;; Requests handling:
+
+(defun geiser-con--req-form (req answer)
+  (let ((con (geiser-con--request-connection req)))
+    (if (geiser-con--has-entered-debugger con answer)
+        `((error (key . geiser-debugger))
+          (output . ,answer))
+      (condition-case err
+          (let ((start (string-match "((\\(?:result)?\\|error\\) " answer)))
+            (or (and start (car (read-from-string answer start)))
+                `((error (key . retort-syntax)) (output . ,answer))))
+        (error `((error (key . geiser-con-error))
+                 (output . ,(format "%s\n(%s)"
+                                    answer (error-message-string err)))))))))
+
+(defun geiser-con--process-completed-request (req answer)
+  (let ((cont (geiser-con--request-continuation req))
+        (id (geiser-con--request-id req))
+        (rstr (geiser-con--request-string req))
+        (form (geiser-con--req-form req answer))
+        (buffer (or (geiser-con--request-buffer req) (current-buffer)))
+        (con (geiser-con--request-connection req)))
+    (if (not cont)
+        (geiser-log--warn "<%s> Droping result for request %S: %s"
+                          id rstr form)
+      (condition-case cerr
+          (with-current-buffer buffer
+            (funcall cont form)
+            (geiser-log--info "<%s>: processed" id))
+        (error (geiser-log--error
+                "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
+    (geiser-con--connection-completed con req)))
+
+(defun geiser-con--connection-add-request (c r)
+  (let ((rstr (geiser-con--request-string r)))
+    (geiser-log--info "REQUEST: <%s>: %s"
+                      (geiser-con--request-id r)
+                      rstr)
+    (geiser-con--connection-activate c)
+    (tq-enqueue (geiser-con--connection-tq c)
+                (concat rstr "\n")
+                (geiser-con--connection-eot c)
+                r
+                'geiser-con--process-completed-request
+                t)))
+
+
+;;; Message sending interface:
+
+(defun geiser-con--send-string (con str cont &optional sbuf)
+  (let ((req (geiser-con--make-request con str cont sbuf)))
+    (geiser-con--connection-add-request con req)
+    req))
+
+(defvar geiser-connection-timeout 30000
+  "Time limit, in msecs, blocking on synchronous evaluation requests")
+
+(defun geiser-con--send-string/wait (con str cont &optional timeout sbuf)
+  (save-current-buffer
+    (let ((proc (and con (geiser-con--connection-process con))))
+      (unless proc (error "Geiser connection not active"))
+      (let* ((req (geiser-con--send-string con str cont sbuf))
+             (id (geiser-con--request-id req))
+             (timeout (/ (or timeout geiser-connection-timeout) 1000.0)))
+        (with-timeout (timeout (geiser-con--request-deactivate req))
+          (condition-case nil
+              (while (and (geiser-con--connection-process con)
+                          (not (geiser-con--connection-completed-p con id)))
+                (accept-process-output proc (/ timeout 10)))
+            (error (geiser-con--request-deactivate req))))))))
+
+
+(provide 'geiser-connection)

elpa/geiser-20171010.1610/geiser-custom.el

@@ -0,0 +1,77 @@
+;;; geiser-custom.el -- customization utilities
+
+;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Feb 14, 2009 21:49
+
+
+
+(require 'font-lock)
+(require 'geiser-base)
+
+
+;;; Customization group:
+
+(defgroup geiser nil
+  "Geiser framework for Scheme-Emacs interaction."
+  :group 'languages)
+
+
+;;; Faces:
+
+(defgroup geiser-faces nil
+  "Faces used by Geiser."
+  :group 'geiser
+  :group 'faces)
+
+(defmacro geiser-custom--defface (face def group doc)
+  (declare (doc-string 4))
+  (let ((face (intern (format "geiser-font-lock-%s" face))))
+    `(defface ,face (face-default-spec ,def)
+       ,(format "Face for %s." doc)
+       :group ',group
+       :group 'geiser-faces)))
+
+(put 'geiser-custom--defface 'lisp-indent-function 1)
+
+
+
+;;; Reload support:
+
+(defvar geiser-custom--memoized-vars nil)
+
+(defun geiser-custom--memoize (name)
+  (add-to-list 'geiser-custom--memoized-vars name))
+
+(defmacro geiser-custom--defcustom (name &rest body)
+  (declare (doc-string 3) (debug (name body)))
+  `(progn
+     (geiser-custom--memoize ',name)
+     (defcustom ,name ,@body)))
+
+(defun geiser-custom--memoized-state ()
+  (let ((result))
+    (dolist (name geiser-custom--memoized-vars result)
+      (when (boundp name)
+        (push (cons name (symbol-value name)) result)))))
+
+
+(put 'geiser-custom--defcustom 'lisp-indent-function 2)
+
+
+(defconst geiser-custom-font-lock-keywords
+  (eval-when-compile
+    `((,(concat "(\\(geiser-custom--\\(?:defcustom\\|defface\\)\\)\\_>"
+                "[ \t'\(]*"
+                "\\(\\(?:\\sw\\|\\s_\\)+\\)?")
+       (1 font-lock-keyword-face)
+       (2 font-lock-variable-name-face nil t)))))
+
+(font-lock-add-keywords 'emacs-lisp-mode geiser-custom-font-lock-keywords)
+
+(provide 'geiser-custom)

elpa/geiser-20171010.1610/geiser-debug.el

@@ -0,0 +1,217 @@
+;;; geiser-debug.el -- displaying debug information and evaluation results
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Feb 23, 2009 22:34
+
+
+
+(require 'geiser-edit)
+(require 'geiser-autodoc)
+(require 'geiser-impl)
+(require 'geiser-eval)
+(require 'geiser-menu)
+(require 'geiser-popup)
+(require 'geiser-base)
+(require 'geiser-image)
+
+
+;;; Customization:
+
+(defgroup geiser-debug nil
+  "Debugging and error display options."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-debug-always-display-sexp-after-p nil
+  "Whether to always display the sexp whose evaluation caused an
+error after the error message in the debug pop-up. If nil,
+expressions shorter than `geiser-debug-long-sexp-lines` lines are
+show before the error message."
+  :group 'geiser-debug
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-debug-long-sexp-lines 6
+  "Length of an expression in order to be relegated to the bottom
+of the debug pop-up (after the error message). If
+`geiser-debug-always-display-sexp-after-p` is t, this variable
+has no effect."
+  :group 'geiser-debug
+  :type 'int)
+
+(geiser-custom--defcustom geiser-debug-jump-to-debug-p t
+  "When set to t (the default), jump to the debug pop-up buffer
+  in case of evaluation errors.
+
+See also `geiser-debug-show-debug-p`. "
+  :group 'geiser-debug
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-debug-show-debug-p t
+  "When set to t (the default), show the debug pop-up buffer in
+  case of evaluation errors.
+
+This option takes effect even if `geiser-debug-jump-to-debug-p`
+is set."
+  :group 'geiser-debug
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-debug-auto-display-images-p t
+  "Whether to automatically invoke the external viewer to display
+images when they're evaluated.
+
+See also `geiser-repl-auto-display-images-p'."
+  :group 'geiser-debug
+  :type 'boolean)
+
+
+;;; Debug buffer mode:
+
+(defvar geiser-debug-mode-map
+  (let ((map (make-sparse-keymap)))
+    (suppress-keymap map)
+    (set-keymap-parent map button-buffer-map)
+    map)
+  "Keymap for `geiser-debug-mode'.")
+
+(define-derived-mode geiser-debug-mode nil "Geiser DBG"
+  "A major mode for displaying Scheme compilation and evaluation results.
+\\{geiser-debug-mode-map}"
+  (buffer-disable-undo)
+  (set-syntax-table scheme-mode-syntax-table)
+  (setq next-error-function 'geiser-edit--open-next)
+  (setq buffer-read-only t))
+
+(defun geiser-debug--button-p (nextp)
+  (let ((m (funcall (if nextp 'next-button 'previous-button) (point))))
+    (and m (funcall (if nextp '< '>) (point) (marker-position m)))))
+
+(geiser-menu--defmenu debug geiser-debug-mode-map
+  ("Next error" "n" forward-button :enable (geiser-debug--button-p t))
+  ("Previous error" "p" backward-button :enable (geiser-debug--button-p t))
+  --
+  ("Quit" nil View-quit))
+
+
+;;; Buffer for displaying evaluation results:
+
+(geiser-popup--define debug "*Geiser dbg*" geiser-debug-mode)
+
+
+;;; Displaying retorts
+
+(geiser-impl--define-caller geiser-debug--display-error
+    display-error (module key message)
+    "This method takes 3 parameters (a module name, the error key,
+and the accompanying error message) and should display
+(in the current buffer) a formatted version of the error. If the
+error was successfully displayed, the call should evaluate to a
+non-null value.")
+
+(geiser-impl--define-caller geiser-debug--enter-debugger
+    enter-debugger ()
+  "This method is called upon entering the debugger, in the REPL
+buffer.")
+
+(defun geiser-debug--display-after (what)
+  (or geiser-debug-always-display-sexp-after-p
+      (>= (with-temp-buffer
+            (insert what)
+            (count-lines (point-min) (point-max)))
+          geiser-debug-long-sexp-lines)))
+
+(defun geiser-debug--insert-res (res)
+  (let ((begin (point)))
+    (insert res)
+    (let ((end (point)))
+      (goto-char begin)
+      (let ((no (geiser-image--replace-images
+                 t geiser-debug-auto-display-images-p)))
+        (goto-char end)
+        (newline 2)
+        (and no (> no 0))))))
+
+(defun geiser-debug--display-retort (what ret &optional res auto-p)
+  (let* ((err (geiser-eval--retort-error ret))
+         (key (geiser-eval--error-key err))
+         (output (geiser-eval--retort-output ret))
+         (impl geiser-impl--implementation)
+         (module (geiser-eval--get-module))
+         (dbg nil)
+         (img nil)
+         (dir default-directory)
+         (buffer (current-buffer))
+         (debug (eq key 'geiser-debugger))
+         (after (geiser-debug--display-after what)))
+    (when debug
+      (switch-to-geiser nil nil buffer)
+      (geiser-debug--enter-debugger impl))
+    (geiser-debug--with-buffer
+      (erase-buffer)
+      (when dir (setq default-directory dir))
+      (unless after
+        (geiser-debug--display-error impl module nil what)
+        (goto-char (point-max))
+        (newline 2))
+      (setq img (when (and res (not err)) (geiser-debug--insert-res res)))
+      (setq dbg (geiser-debug--display-error impl module key output))
+      (when after
+        (goto-char (point-max))
+        (insert "\nExpression evaluated was:\n\n")
+        (geiser-debug--display-error impl module nil what))
+      (goto-char (point-min)))
+    (when (or img dbg)
+      (when (or geiser-debug-jump-to-debug-p geiser-debug-show-debug-p)
+        (if geiser-debug-jump-to-debug-p
+            (geiser-debug--pop-to-buffer)
+          (display-buffer (geiser-debug--buffer))
+          (when dbg
+            (ignore-errors (next-error))
+            (message "=> %s" dbg)))))))
+
+(defsubst geiser-debug--wrap-region (str)
+  (format "(begin %s)" str))
+
+(defun geiser-debug--unwrap (str)
+  (if (string-match "(begin[ \t\n\v\r]+\\(.+\\)*)" str)
+      (match-string 1 str)
+    str))
+
+(defun geiser-debug--send-region (compile start end and-go wrap &optional nomsg)
+  (let* ((str (buffer-substring-no-properties start end))
+         (wrapped (if wrap (geiser-debug--wrap-region str) str))
+         (code `(,(if compile :comp :eval) (:scm ,wrapped)))
+         (ret (geiser-eval--send/wait code))
+         (res (geiser-eval--retort-result-str ret nil))
+         (err (geiser-eval--retort-error ret)))
+    (when and-go (funcall and-go))
+    (when (not err)
+      (save-excursion
+        (goto-char (/ (+ end start) 2))
+        (geiser-autodoc--clean-cache))
+      (unless nomsg (message "%s" res)))
+    (geiser-debug--display-retort (geiser-syntax--scheme-str str) ret res)
+    ret))
+
+(defun geiser-debug--expand-region (start end all wrap)
+  (let* ((str (buffer-substring-no-properties start end))
+         (wrapped (if wrap (geiser-debug--wrap-region str) str))
+         (code `(:eval (:ge macroexpand (quote (:scm ,wrapped))
+                            ,(if all :t :f))))
+         (ret (geiser-eval--send/wait code))
+         (err (geiser-eval--retort-error ret))
+         (result (geiser-eval--retort-result ret)))
+    (if err
+        (geiser-debug--display-retort str ret)
+      (geiser-debug--with-buffer
+        (erase-buffer)
+        (insert (format "%s" (if wrap (geiser-debug--unwrap result) result)))
+        (goto-char (point-min)))
+      (geiser-debug--pop-to-buffer))))
+
+
+(provide 'geiser-debug)

elpa/geiser-20171010.1610/geiser-doc.el

@@ -0,0 +1,486 @@
+;;; geiser-doc.el -- accessing scheme-provided documentation
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Feb 14, 2009 14:09
+
+
+
+(require 'geiser-edit)
+(require 'geiser-impl)
+(require 'geiser-completion)
+(require 'geiser-autodoc)
+(require 'geiser-eval)
+(require 'geiser-syntax)
+(require 'geiser-menu)
+(require 'geiser-popup)
+(require 'geiser-custom)
+(require 'geiser-base)
+
+(require 'button)
+
+
+;;; Customization:
+
+(defgroup geiser-doc nil
+  "Options for documentation buffers."
+  :group 'geiser)
+
+(geiser-custom--defface doc-title
+  'bold geiser-doc "article titles in documentation buffers")
+
+(geiser-custom--defface doc-link
+  'link geiser-doc "links in documentation buffers")
+
+(geiser-custom--defface doc-button
+  'button geiser-doc "buttons in documentation buffers")
+
+
+;;; Implementation
+(geiser-impl--define-caller geiser-doc--external-help external-help
+                            (symbol module)
+  "By default, Geiser will display help about an identifier in a
+help buffer, after collecting the associated signature and
+docstring. You can provide an alternative function for displaying
+help (e.g. browse an HTML page) implementing this method.")
+
+
+;;; Documentation browser history:
+
+(defvar geiser-doc-history-size 50)
+(defvar geiser-doc--history nil)
+
+(defun geiser-doc--make-history ()
+  (list nil                                   ; current
+        (make-ring geiser-doc-history-size)   ; previous
+        (make-ring geiser-doc-history-size))) ; next
+
+(setq geiser-doc--history (geiser-doc--make-history))
+
+(defvar session-globals-exclude)
+(eval-after-load "session"
+  '(add-to-list 'session-globals-exclude 'geiser-doc--history))
+
+(defsubst geiser-doc--history-current ()
+  (car geiser-doc--history))
+
+(defsubst geiser-doc--history-previous-link ()
+  (ring-ref (cadr geiser-doc--history) 0))
+
+(defsubst geiser-doc--history-next-link ()
+  (ring-ref (car (cddr geiser-doc--history)) 0))
+
+(defun geiser-doc--history-push (link)
+  (unless (or (null link) (equal link (geiser-doc--history-current)))
+    (when (not (null (geiser-doc--history-current)))
+      (let ((next (geiser-doc--history-next)))
+        (unless (equal link next)
+          (when next (geiser-doc--history-previous))
+          (ring-insert (nth 1 geiser-doc--history)
+                       (car geiser-doc--history)))))
+    (setcar geiser-doc--history link))
+  link)
+
+(defsubst geiser-doc--history-next-p ()
+  (not (ring-empty-p (nth 2 geiser-doc--history))))
+
+(defun geiser-doc--history-next (&optional forget-current)
+  (when (geiser-doc--history-next-p)
+    (when (and (car geiser-doc--history) (not forget-current))
+      (ring-insert (nth 1 geiser-doc--history) (car geiser-doc--history)))
+    (setcar geiser-doc--history (ring-remove (nth 2 geiser-doc--history) 0))))
+
+(defsubst geiser-doc--history-previous-p ()
+  (not (ring-empty-p (nth 1 geiser-doc--history))))
+
+(defun geiser-doc--history-previous (&optional forget-current)
+  (when (geiser-doc--history-previous-p)
+    (when (and (car geiser-doc--history) (not forget-current))
+      (ring-insert (nth 2 geiser-doc--history) (car geiser-doc--history)))
+    (setcar geiser-doc--history (ring-remove (nth 1 geiser-doc--history) 0))))
+
+
+;;; Links
+
+(defsubst geiser-doc--make-link (target module impl)
+  (list target module impl))
+
+(defsubst geiser-doc--link-target (link)
+  (nth 0 link))
+
+(defsubst geiser-doc--link-module (link)
+  (nth 1 link))
+
+(defsubst geiser-doc--link-impl (link)
+  (nth 2 link))
+
+(defun geiser-doc--follow-link (link)
+  (let ((target (geiser-doc--link-target link))
+        (module (geiser-doc--link-module link))
+        (impl (geiser-doc--link-impl link)))
+    (when (and (or target module) impl)
+      (with--geiser-implementation impl
+        (if (null target)
+            (geiser-doc-module module impl)
+          (let ((geiser-eval--get-module-function (lambda (x) module)))
+            (geiser-doc-symbol target module impl)))))))
+
+(make-variable-buffer-local
+ (defvar geiser-doc--buffer-link nil))
+
+(defsubst geiser-doc--implementation ()
+  (geiser-doc--link-impl geiser-doc--buffer-link))
+
+(defun geiser-doc--button-action (button)
+  (let ((link (button-get button 'geiser-link)))
+    (when link (geiser-doc--follow-link link))))
+
+(define-button-type 'geiser-doc--button
+  'action 'geiser-doc--button-action
+  'follow-link t)
+
+(defun geiser-doc--make-module-button (beg end module impl)
+  (let ((link (geiser-doc--make-link nil module impl))
+        (help (format "Help for module %s" module)))
+    (make-text-button beg end :type 'geiser-doc--button
+                      'face 'geiser-font-lock-doc-link
+                      'geiser-link link
+                      'help-echo help)))
+
+(defun geiser-doc--insert-button (target module impl &optional sign)
+  (let ((link (geiser-doc--make-link target module impl))
+        (text (format "%s" (or (and sign
+                                    (geiser-autodoc--str* sign))
+                               target
+                               module)))
+        (help (format "%smodule %s"
+                      (if target (format "%s in " target) "")
+                      (or module "<unknown>"))))
+    (insert-text-button text
+                        :type 'geiser-doc--button
+                        'face 'geiser-font-lock-doc-link
+                        'geiser-link link
+                        'help-echo help)))
+
+(defun geiser-doc--xbutton-action (button)
+  (when geiser-doc--buffer-link
+    (let ((kind (or (button-get button 'x-kind) 'source))
+          (target (geiser-doc--link-target geiser-doc--buffer-link))
+          (module (geiser-doc--link-module geiser-doc--buffer-link))
+          (impl (geiser-doc--link-impl geiser-doc--buffer-link)))
+      (with--geiser-implementation impl
+        (cond ((eq kind 'source)
+               (if target (geiser-edit-symbol target nil (point-marker))
+                 (geiser-edit-module module)))
+              ((eq kind 'manual)
+               (geiser-doc--external-help impl
+                                          (or target module)
+                                          module)))))))
+
+(define-button-type 'geiser-doc--xbutton
+  'action 'geiser-doc--xbutton-action
+  'face 'geiser-font-lock-doc-button
+  'follow-link t)
+
+(defun geiser-doc--insert-xbutton (&optional manual)
+  (let ((label (if manual "[manual]" "[source]"))
+        (help (if manual "Look up in Scheme manual" "Go to definition")))
+  (insert-text-button label
+                      :type 'geiser-doc--xbutton
+                      'help-echo help
+                      'x-kind (if manual 'manual 'source))))
+
+(defun geiser-doc--insert-xbuttons (impl)
+  (when (geiser-impl--method 'external-help impl)
+    (geiser-doc--insert-xbutton t)
+    (insert " "))
+  (geiser-doc--insert-xbutton))
+
+(defun geiser-doc--insert-nav-button (next)
+  (let* ((lnk (if next (geiser-doc--history-next-link)
+                (geiser-doc--history-previous-link)))
+         (what (geiser-doc--link-target lnk))
+         (what (or what (geiser-doc--link-module lnk)))
+         (action (if next '(lambda (b) (geiser-doc-next))
+                   '(lambda (b) (geiser-doc-previous)))))
+    (insert-text-button (if next "[forward]" "[back]")
+                        'action action
+                        'help-echo (format "Previous help item (%s)" what)
+                        'face 'geiser-font-lock-doc-button
+                        'follow-link t)))
+
+
+;;; Auxiliary functions:
+
+(defun geiser-doc--manual-available-p ()
+  (geiser-impl--method 'external-help geiser-impl--implementation))
+
+(defun geiser-doc--module (&optional mod impl)
+  (let ((impl (or impl (geiser-doc--link-impl geiser-doc--buffer-link)))
+        (mod (or mod (geiser-doc--link-module geiser-doc--buffer-link))))
+    (geiser-impl--call-method 'find-module impl mod)))
+
+(defun geiser-doc--insert-title (title)
+  (let ((p (point)))
+    (insert (format "%s" title))
+    (fill-paragraph nil)
+    (let ((indent-line-function 'lisp-indent-line))
+      (indent-region p (point)))
+    (put-text-property p (point) 'face 'geiser-font-lock-doc-title)
+    (newline)))
+
+(defun geiser-doc--insert-list (title lst module impl)
+  (when lst
+    (geiser-doc--insert-title title)
+    (newline)
+    (dolist (w lst)
+      (let ((name (car w))
+            (signature (cdr (assoc "signature" w)))
+            (info (cdr (assoc "info" w))))
+        (insert "\t- ")
+        (if module
+            (geiser-doc--insert-button name module impl signature)
+          (geiser-doc--insert-button nil name impl))
+        (when info (insert (format "  %s" info)))
+        (newline)))
+    (newline)))
+
+(defun geiser-doc--insert-footer (impl)
+  (newline 2)
+  (geiser-doc--insert-xbuttons impl)
+  (let* ((prev (and (geiser-doc--history-previous-p) 8))
+         (nxt (and (geiser-doc--history-next-p) 10))
+         (len (max 1 (- (window-width)
+                        (- (point) (line-beginning-position))
+                        (or prev 0)
+                        (or nxt 0)))))
+    (when (or prev nxt)
+      (insert (make-string len ?\ )))
+    (when prev
+      (geiser-doc--insert-nav-button nil)
+      (insert " "))
+    (when nxt
+      (geiser-doc--insert-nav-button t))))
+
+
+;;; Documentation browser and mode:
+
+(defun geiser-doc-edit-symbol-at-point ()
+  "Open definition of symbol at point."
+  (interactive)
+  (let* ((impl (geiser-doc--implementation))
+         (module (geiser-doc--module)))
+    (unless (and impl module)
+      (error "I don't know what module this buffer refers to."))
+    (with--geiser-implementation impl
+      (geiser-edit-symbol-at-point))))
+
+(defvar geiser-doc-mode-map
+  (let ((map (make-sparse-keymap)))
+    (suppress-keymap map)
+    (set-keymap-parent map button-buffer-map)
+    map)
+  "Keymap for `geiser-doc-mode'.")
+
+(defun geiser-doc-switch-to-repl ()
+  (interactive)
+  (switch-to-geiser nil nil (current-buffer)))
+
+(geiser-menu--defmenu doc geiser-doc-mode-map
+  ("Next link" ("n") forward-button)
+  ("Previous link" ("p") backward-button)
+  ("Next section" ("N") geiser-doc-next-section)
+  ("Previous section" ("P") geiser-doc-previous-section)
+  --
+  ("Next page" ("f") geiser-doc-next "Next item"
+   :enable (geiser-doc--history-next-p))
+  ("Previous page" ("b") geiser-doc-previous "Previous item"
+   :enable (geiser-doc--history-previous-p))
+  --
+  ("Go to REPL" ("z" "\C-cz" "\C-c\C-z") geiser-doc-switch-to-repl)
+  ("Refresh" ("g" "r") geiser-doc-refresh "Refresh current page")
+  --
+  ("Edit symbol" ("." "\M-.") geiser-doc-edit-symbol-at-point
+   :enable (geiser--symbol-at-point))
+  --
+  ("Kill item" "k" geiser-doc-kill-page "Kill this page")
+  ("Clear history" "c" geiser-doc-clean-history)
+  --
+  (custom "Browser options" geiser-doc)
+  --
+  ("Quit" nil View-quit))
+
+(define-derived-mode geiser-doc-mode nil "Geiser Doc"
+  "Major mode for browsing scheme documentation.
+\\{geiser-doc-mode-map}"
+  (buffer-disable-undo)
+  (setq truncate-lines t)
+  (set-syntax-table scheme-mode-syntax-table)
+  (setq geiser-eval--get-module-function 'geiser-doc--module)
+  (setq buffer-read-only t))
+
+(geiser-popup--define doc "*Geiser documentation*" geiser-doc-mode)
+
+
+;;; Commands:
+
+(defun geiser-doc--get-docstring (symbol module)
+  (geiser-eval--send/result
+   `(:eval (:ge symbol-documentation ',symbol) ,module)))
+
+(defun geiser-doc--get-module-exports (module)
+  (geiser-eval--send/result
+   `(:eval (:ge module-exports '(:module ,module)) :f)))
+
+(defun geiser-doc--buttonize-modules (impl)
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward "in module \\([^.\n]+\\)[.\n ]" nil t)
+      (geiser-doc--make-module-button (match-beginning 1)
+                                      (match-end 1)
+                                      (geiser-doc--module (match-string 1)
+                                                          impl)
+                                      impl))))
+
+(defun geiser-doc--render-docstring
+  (docstring symbol &optional module impl)
+  (erase-buffer)
+  (geiser-doc--insert-title
+   (geiser-autodoc--str* (cdr (assoc "signature" docstring))))
+  (newline)
+  (insert (or (cdr (assoc "docstring" docstring)) ""))
+  (geiser-doc--buttonize-modules impl)
+  (setq geiser-doc--buffer-link
+        (geiser-doc--history-push (geiser-doc--make-link symbol
+                                                         module
+                                                         impl)))
+  (geiser-doc--insert-footer impl)
+  (goto-char (point-min)))
+
+(defun geiser-doc-symbol (symbol &optional module impl)
+  (let* ((impl (or impl geiser-impl--implementation))
+         (module (geiser-doc--module (or module (geiser-eval--get-module))
+                                     impl)))
+    (let ((ds (geiser-doc--get-docstring symbol module)))
+      (if (or (not ds) (not (listp ds)))
+          (message "No documentation available for '%s'" symbol)
+        (geiser-doc--with-buffer
+          (geiser-doc--render-docstring ds symbol module impl))
+        (geiser-doc--pop-to-buffer)))))
+
+(defun geiser-doc-symbol-at-point (&optional arg)
+  "Get docstring for symbol at point.
+With prefix argument, ask for symbol (with completion)."
+  (interactive "P")
+  (let ((symbol (or (and (not arg) (geiser--symbol-at-point))
+                    (geiser-completion--read-symbol
+                     "Symbol: " (geiser--symbol-at-point)))))
+    (when symbol (geiser-doc-symbol symbol))))
+
+(defun geiser-doc-look-up-manual (&optional arg)
+  "Look up manual for symbol at point.
+With prefix argument, ask for the lookup symbol (with completion)."
+  (interactive "P")
+  (unless (geiser-doc--manual-available-p)
+    (error "No manual available"))
+  (let ((symbol (or (and (not arg) (geiser--symbol-at-point))
+                    (geiser-completion--read-symbol "Symbol: "))))
+    (geiser-doc--external-help geiser-impl--implementation
+                               symbol
+                               (geiser-eval--get-module))))
+
+(defconst geiser-doc--sections '(("Procedures:" "procs")
+                                 ("Syntax:" "syntax")
+                                 ("Variables:" "vars")
+                                 ("Submodules:" "modules" t)))
+
+(defconst geiser-doc--sections-re
+  (format "^%s\n" (regexp-opt (mapcar 'car geiser-doc--sections))))
+
+(defun geiser-doc-module (&optional module impl)
+  "Display information about a given module."
+  (interactive)
+  (let* ((impl (or impl geiser-impl--implementation))
+         (module (geiser-doc--module (or module
+                                         (geiser-completion--read-module))
+                                     impl))
+         (msg (format "Retrieving documentation for %s ..." module))
+         (exports (progn
+                    (message "%s" msg)
+                    (geiser-doc--get-module-exports module))))
+    (if (not exports)
+        (message "No information available for %s" module)
+      (geiser-doc--with-buffer
+        (erase-buffer)
+        (geiser-doc--insert-title (format "%s" module))
+        (newline)
+        (dolist (g geiser-doc--sections)
+          (geiser-doc--insert-list (car g)
+                                   (cdr (assoc (cadr g) exports))
+                                   (and (not (cddr g)) module)
+                                   impl))
+        (setq geiser-doc--buffer-link
+              (geiser-doc--history-push
+               (geiser-doc--make-link nil module impl)))
+        (geiser-doc--insert-footer impl)
+        (goto-char (point-min)))
+      (message "%s done" msg)
+      (geiser-doc--pop-to-buffer))))
+
+(defun geiser-doc-next-section ()
+  "Move to next section in this page."
+  (interactive)
+  (forward-line)
+  (re-search-forward geiser-doc--sections-re nil t)
+  (forward-line -1))
+
+(defun geiser-doc-previous-section ()
+  "Move to previous section in this page."
+  (interactive)
+  (re-search-backward geiser-doc--sections-re nil t))
+
+(defun geiser-doc-next (&optional forget-current)
+  "Go to next page in documentation browser.
+With prefix, the current page is deleted from history."
+  (interactive "P")
+  (let ((link (geiser-doc--history-next forget-current)))
+    (unless link (error "No next page"))
+    (geiser-doc--follow-link link)))
+
+(defun geiser-doc-previous (&optional forget-current)
+  "Go to previous page in documentation browser.
+With prefix, the current page is deleted from history."
+  (interactive "P")
+  (let ((link (geiser-doc--history-previous forget-current)))
+    (unless link (error "No previous page"))
+    (geiser-doc--follow-link link)))
+
+(defun geiser-doc-kill-page ()
+  "Kill current page if a previous or next one exists."
+  (interactive)
+  (condition-case nil
+      (geiser-doc-previous t)
+    (error (geiser-doc-next t))))
+
+(defun geiser-doc-refresh ()
+  "Refresh the contents of current page."
+  (interactive)
+  (when geiser-doc--buffer-link
+    (geiser-doc--follow-link geiser-doc--buffer-link)))
+
+(defun geiser-doc-clean-history ()
+  "Clean up the document browser history."
+  (interactive)
+  (when (y-or-n-p "Clean browsing history? ")
+    (setq geiser-doc--history (geiser-doc--make-history))
+    (geiser-doc-refresh))
+  (message ""))
+
+
+
+(provide 'geiser-doc)

elpa/geiser-20171010.1610/geiser-edit.el

@@ -0,0 +1,271 @@
+;;; geiser-edit.el -- scheme edit locations
+
+;; Copyright (C) 2009, 2010, 2012, 2013 Jose Antonio Ortega Ruiz
+
+;; 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: Wed Feb 11, 2009 21:07
+
+
+
+(require 'geiser-completion)
+(require 'geiser-eval)
+(require 'geiser-custom)
+(require 'geiser-base)
+
+(require 'etags)
+
+
+;;; Customization:
+
+(defmacro geiser-edit--define-custom-visit (var group doc)
+  `(geiser-custom--defcustom ,var nil
+     ,doc
+     :group ',group
+     :type '(choice (const :tag "Other window" window)
+                    (const :tag "Other frame" frame)
+                    (const :tag "Current window" nil))))
+
+(geiser-edit--define-custom-visit
+ geiser-edit-symbol-method geiser-mode
+ "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point]
+or following links in error buffers.")
+
+(geiser-custom--defface error-link
+  'link geiser-debug "links in error buffers")
+
+
+;;; Auxiliar functions:
+
+(defun geiser-edit--visit-file (file method)
+  (cond ((eq method 'window) (pop-to-buffer (find-file-noselect file t)))
+        ((eq method 'frame) (find-file-other-frame file))
+        ((eq method 'noselect) (find-file-noselect file t))
+        (t (find-file file))))
+
+(defsubst geiser-edit--location-name (loc)
+  (cdr (assoc "name" loc)))
+
+(defsubst geiser-edit--location-file (loc)
+  (cdr (assoc "file" loc)))
+
+(defsubst geiser-edit--to-number (x)
+  (cond ((numberp x) x)
+        ((stringp x) (string-to-number x))))
+
+(defsubst geiser-edit--location-line (loc)
+  (geiser-edit--to-number (cdr (assoc "line" loc))))
+
+(defsubst geiser-edit--location-column (loc)
+  (geiser-edit--to-number (cdr (assoc "column" loc))))
+
+(defsubst geiser-edit--make-location (name file line column)
+  `(("name" . ,name) ("file" . ,file) ("line" . ,line) ("column" . ,column)))
+
+(defconst geiser-edit--def-re
+  (regexp-opt '("define"
+                "defmacro"
+                "define-macro"
+                "define-syntax"
+                "define-syntax-rule"
+                "-define-syntax"
+                "-define"
+                "define*"
+                "define-method"
+                "define-class"
+                "define-struct")))
+
+(defconst geiser-edit--def-re*
+  (regexp-opt '("define-syntaxes" "define-values")))
+
+(defsubst geiser-edit--def-re (thing)
+  (format "(%s +(?%s\\_>"
+          geiser-edit--def-re
+          (regexp-quote (format "%s" thing))))
+
+(defsubst geiser-edit--def-re* (thing)
+  (format "(%s +([^)]*?\\_<%s\\_>"
+          geiser-edit--def-re*
+          (regexp-quote (format "%s" thing))))
+
+(defsubst geiser-edit--symbol-re (thing)
+  (format "\\_<%s\\_>" (regexp-quote (format "%s" thing))))
+
+(defun geiser-edit--goto-line (symbol line)
+  (goto-char (point-min))
+  (if (numberp line)
+      (forward-line (max 0 (1- line)))
+    (goto-char (point-min))
+    (when (or (re-search-forward (geiser-edit--def-re symbol) nil t)
+              (re-search-forward (geiser-edit--def-re* symbol) nil t)
+              (re-search-forward (geiser-edit--symbol-re symbol) nil t))
+      (goto-char (match-beginning 0)))))
+
+(defun geiser-edit--try-edit-location (symbol loc &optional method)
+  (let ((symbol (or (geiser-edit--location-name loc) symbol))
+        (file (geiser-edit--location-file loc))
+        (line (geiser-edit--location-line loc))
+        (col (geiser-edit--location-column loc)))
+    (unless file (error "Couldn't find edit location for '%s'" symbol))
+    (unless (file-readable-p file) (error "Couldn't open '%s' for read" file))
+    (geiser-edit--visit-file file (or method geiser-edit-symbol-method))
+    (geiser-edit--goto-line symbol line)
+    (when col
+      (beginning-of-line)
+      (forward-char col))
+    (cons (current-buffer) (point))))
+
+(defsubst geiser-edit--try-edit (symbol ret &optional method)
+  (geiser-edit--try-edit-location symbol
+                                  (geiser-eval--retort-result ret)
+                                  method))
+
+
+;;; Links
+
+(define-button-type 'geiser-edit--button
+  'action 'geiser-edit--button-action
+  'face 'geiser-font-lock-error-link
+  'follow-link t)
+
+(defun geiser-edit--button-action (button)
+  (let ((loc (button-get button 'geiser-location))
+        (method (button-get button 'geiser-method)))
+    (when loc (geiser-edit--try-edit-location nil loc method))))
+
+(defun geiser-edit--make-link (beg end file line col &optional method)
+  (make-button beg end
+               :type 'geiser-edit--button
+               'geiser-method method
+               'geiser-location
+               (geiser-edit--make-location 'error file line col)
+               'help-echo "Go to error location"))
+
+(defconst geiser-edit--default-file-rx
+  "^[ \t]*\\([^<>:\n\"]+\\):\\([0-9]+\\):\\([0-9]+\\)")
+
+(defun geiser-edit--buttonize-files (&optional rx no-fill)
+  (let ((rx (or rx geiser-edit--default-file-rx))
+        (fill-column (- (window-width) 2)))
+    (save-excursion
+      (while (re-search-forward rx nil t)
+        (geiser-edit--make-link (match-beginning 1)
+                                (match-end 1)
+                                (match-string 1)
+                                (match-string 2)
+                                (match-string 3)
+                                'window)
+        (unless no-fill (fill-region (match-end 0) (point-at-eol)))))))
+
+(defun geiser-edit--open-next (&optional n reset)
+  (interactive)
+  (let* ((n (or n 1))
+         (nxt (if (< n 0) 'backward-button 'forward-button))
+         (msg (if (< n 0) "previous" "next"))
+         (n (abs n))
+         (p (point))
+         (found nil))
+    (when reset (goto-char (point-min)))
+    (while (> n 0)
+      (let ((b (ignore-errors (funcall nxt 1))))
+        (unless b (setq n 0))
+        (when (and b (eq (button-type b) 'geiser-edit--button))
+          (setq n (- n 1))
+          (when (<= n 0)
+            (setq found t)
+            (push-button (point))))))
+    (unless found
+      (goto-char p)
+      (error "No %s error" msg))))
+
+
+;;; Visibility
+(defun geiser-edit--cloak (form)
+  (intern (format "geiser-edit-cloak-%s" form)))
+
+(defun geiser-edit--hide (form)
+  (geiser-edit--show form)
+  (let ((cloak (geiser-edit--cloak form)))
+    (save-excursion
+      (goto-char (point-min))
+      (while (re-search-forward (format "(%s\\b" form) nil t)
+        (let* ((beg (match-beginning 0))
+               (end (progn (ignore-errors (goto-char beg) (forward-sexp))
+                           (point))))
+          (when (> end beg)
+            (overlay-put (make-overlay beg end) 'invisible cloak)))))
+    (add-to-invisibility-spec (cons cloak t))))
+
+(defun geiser-edit--show (form)
+  (let ((cloak (geiser-edit--cloak form)))
+    (remove-overlays nil nil 'invisible cloak)
+    (remove-from-invisibility-spec (cons cloak t))))
+
+(defun geiser-edit--show-all ()
+  (remove-overlays)
+  (setq buffer-invisibility-spec '(t)))
+
+(defun geiser-edit--toggle-visibility (form)
+  (if (and (listp buffer-invisibility-spec)
+           (assoc (geiser-edit--cloak form) buffer-invisibility-spec))
+      (geiser-edit--show form)
+    (geiser-edit--hide form)))
+
+
+;;; Commands:
+
+(defvar geiser-edit--symbol-history nil)
+
+(defun geiser-edit-symbol (symbol &optional method marker)
+  "Asks for a symbol to edit, with completion."
+  (interactive
+   (list (geiser-completion--read-symbol "Edit symbol: "
+                                         nil
+                                         geiser-edit--symbol-history)))
+  (let ((cmd `(:eval (:ge symbol-location ',symbol))))
+    (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method)
+    (when marker (ring-insert find-tag-marker-ring marker))))
+
+(defun geiser-edit-symbol-at-point (&optional arg)
+  "Opens a new window visiting the definition of the symbol at point.
+With prefix, asks for the symbol to edit."
+  (interactive "P")
+  (let* ((symbol (or (and (not arg) (geiser--symbol-at-point))
+                     (geiser-completion--read-symbol "Edit symbol: ")))
+         (cmd `(:eval (:ge symbol-location ',symbol)))
+         (marker (point-marker)))
+    (condition-case err
+        (progn (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd))
+               (when marker (ring-insert find-tag-marker-ring marker)))
+      (error (condition-case nil
+                 (geiser-edit-module-at-point)
+               (error (error (error-message-string err))))))))
+
+(defun geiser-pop-symbol-stack ()
+  "Pop back to where \\[geiser-edit-symbol-at-point] was last invoked."
+  (interactive)
+  (condition-case nil
+      (pop-tag-mark)
+    (error "No previous location for find symbol invocation")))
+
+(defun geiser-edit-module (module &optional method)
+  "Asks for a module and opens it in a new buffer."
+  (interactive (list (geiser-completion--read-module)))
+  (let ((cmd `(:eval (:ge module-location '(:module ,module)))))
+    (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method)))
+
+
+(defun geiser-edit-module-at-point ()
+  "Opens a new window visiting the module at point."
+  (interactive)
+  (let ((marker (point-marker)))
+    (geiser-edit-module (or (geiser-completion--module-at-point)
+                            (geiser-completion--read-module)))
+    (when marker (ring-insert find-tag-marker-ring marker))))
+
+
+
+(provide 'geiser-edit)

elpa/geiser-20171010.1610/geiser-eval.el

@@ -0,0 +1,209 @@
+;;; geiser-eval.el -- sending scheme code for evaluation
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Feb 07, 2009 22:35
+
+;; Functions, building on top of geiser-connection, to evaluate scheme
+;; code.
+
+
+
+(require 'geiser-impl)
+(require 'geiser-connection)
+(require 'geiser-syntax)
+(require 'geiser-log)
+(require 'geiser-base)
+
+
+;;; Plug-able functions:
+
+(make-variable-buffer-local
+ (defvar geiser-eval--get-module-function nil))
+(set-default 'geiser-eval--get-module-function nil)
+
+(defvar geiser-eval--get-impl-module nil)
+(geiser-impl--register-local-method
+ 'geiser-eval--get-impl-module 'find-module '(lambda (&rest args) nil)
+ "Function used to obtain the module for current buffer. It takes
+an optional argument, for cases where we want to force its
+value.")
+
+(defun geiser-eval--get-module (&optional module)
+  (if geiser-eval--get-module-function
+      (funcall geiser-eval--get-module-function module)
+    (funcall geiser-eval--get-impl-module module)))
+
+(defvar geiser-eval--geiser-procedure-function)
+(geiser-impl--register-local-method
+ 'geiser-eval--geiser-procedure-function 'marshall-procedure 'identity
+ "Function to translate a bare procedure symbol to one executable
+in the Scheme context. Return NULL for unsupported ones; at the
+very least, EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be
+supported.")
+
+(defvar geiser-eval--unsupported nil)
+(geiser-impl--register-local-variable
+ 'geiser-eval--unsupported 'unsupported-procedures nil
+ "A list, or function returning a list, of the Geiser procedures
+not implemented by this Scheme implementation. Possible values
+include macroexpand, completions, module-completions, find-file,
+symbol-location, module-location, symbol-documentation,
+module-exports, autodoc, callers, callees and generic-methods.")
+
+(defun geiser-eval--supported-p (feat)
+  (or (not geiser-eval--unsupported)
+      (not (memq feat geiser-eval--unsupported))))
+
+(defsubst geiser-eval--form (&rest args)
+  (when (not (geiser-eval--supported-p (car args)))
+    (error "Sorry, the %s scheme implementation does not support Geiser's %s"
+           geiser-impl--implementation (car args)))
+  (apply geiser-eval--geiser-procedure-function args))
+
+
+;;; Code formatting:
+
+(defsubst geiser-eval--load-file (file)
+  (geiser-eval--form 'load-file
+                     (geiser-eval--scheme-str file)))
+
+(defsubst geiser-eval--comp-file (file)
+  (geiser-eval--form 'compile-file
+                     (geiser-eval--scheme-str file)))
+
+(defsubst geiser-eval--module (code)
+  (geiser-eval--scheme-str
+   (cond ((or (null code) (eq code :t) (eq code :buffer))
+          (geiser-eval--get-module))
+         ((or (eq code :repl) (eq code :f)) :f)
+         (t (geiser-eval--get-module code)))))
+
+(defsubst geiser-eval--eval (code)
+  (geiser-eval--form 'eval
+                     (geiser-eval--module (nth 1 code))
+                     (geiser-eval--scheme-str (nth 0 code))))
+
+(defsubst geiser-eval--comp (code)
+  (geiser-eval--form 'compile
+                     (geiser-eval--module (nth 1 code))
+                     (geiser-eval--scheme-str (nth 0 code))))
+
+(defsubst geiser-eval--ge (proc args)
+  (apply 'geiser-eval--form (cons proc
+                                  (mapcar 'geiser-eval--scheme-str args))))
+
+(defun geiser-eval--scheme-str (code)
+  (cond ((null code) "'()")
+        ((eq code :f) "#f")
+        ((eq code :t) "#t")
+        ((listp code)
+         (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code)))
+               ((eq (car code) :comp) (geiser-eval--comp (cdr code)))
+               ((eq (car code) :load-file)
+                (geiser-eval--load-file (cadr code)))
+               ((eq (car code) :comp-file)
+                (geiser-eval--comp-file (cadr code)))
+               ((eq (car code) :module) (geiser-eval--module (cadr code)))
+               ((eq (car code) :ge) (geiser-eval--ge (cadr code)
+                                                     (cddr code)))
+               ((eq (car code) :scm) (cadr code))
+               (t (concat "("
+                          (mapconcat 'geiser-eval--scheme-str code " ")
+                          ")"))))
+        ((symbolp code) (substring-no-properties (format "%s" code)))
+        (t (substring-no-properties (format "%S" code)))))
+
+
+;;; Code sending:
+
+(defvar geiser-eval--default-connection-function nil)
+
+(defsubst geiser-eval--connection ()
+  (and geiser-eval--default-connection-function
+       (funcall geiser-eval--default-connection-function)))
+
+(defsubst geiser-eval--log (s)
+  (geiser-log--info "RETORT: %S" s)
+  s)
+
+(defsubst geiser-eval--code-str (code)
+  (if (stringp code) code (geiser-eval--scheme-str code)))
+
+(defsubst geiser-eval--send (code cont &optional buffer)
+  (geiser-con--send-string (geiser-eval--connection)
+                           (geiser-eval--code-str code)
+                           cont
+                           buffer))
+
+(defvar geiser-eval--sync-retort nil)
+(defun geiser-eval--set-sync-retort (s)
+  (setq geiser-eval--sync-retort (geiser-eval--log s)))
+
+(defun geiser-eval--send/wait (code &optional timeout buffer)
+  (setq geiser-eval--sync-retort nil)
+  (geiser-con--send-string/wait (geiser-eval--connection)
+                                (geiser-eval--code-str code)
+                                'geiser-eval--set-sync-retort
+                                timeout
+                                buffer)
+  geiser-eval--sync-retort)
+
+
+;;; Retort parsing:
+
+(defsubst geiser-eval--retort-p (ret)
+  (and (listp ret) (or (assoc 'error ret) (assoc 'result ret))))
+
+(defsubst geiser-eval--retort-result (ret)
+  (let ((values (cdr (assoc 'result ret))))
+    (car (geiser-syntax--read-from-string (car values)))))
+
+(defsubst geiser-eval--send/result (code &optional timeout buffer)
+  (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer)))
+
+(defun geiser-eval--retort-result-str (ret prefix)
+  (let* ((prefix (or prefix "=> "))
+         (nlprefix (concat "\n" prefix))
+         (values (cdr (assoc 'result ret))))
+    (if values
+        (concat prefix (mapconcat 'identity values nlprefix))
+      (or prefix "(No value)"))))
+
+(defsubst geiser-eval--retort-output (ret)
+  (cdr (assq 'output ret)))
+
+(defsubst geiser-eval--retort-error (ret)
+  (cdr (assq 'error ret)))
+
+(defsubst geiser-eval--error-key (err)
+  (cdr (assq 'key err)))
+
+(defsubst geiser-eval--error-subr (err)
+  (cdr (assq 'subr err)))
+
+(defsubst geiser-eval--error-msg (err)
+  (cdr (assq 'msg err)))
+
+(defsubst geiser-eval--error-rest (err)
+  (cdr (assq 'rest err)))
+
+(defun geiser-eval--error-str (err)
+  (let* ((key (geiser-eval--error-key err))
+         (key-str (if key (format ": %s" key) ":"))
+         (subr (geiser-eval--error-subr err))
+         (subr-str (if subr (format " (%s):" subr) ""))
+         (msg (geiser-eval--error-msg err))
+         (msg-str (if msg (format "\n  %s" msg) ""))
+         (rest (geiser-eval--error-rest err))
+         (rest-str (if rest (format "\n  %s" rest) "")))
+    (format "Error%s%s%s%s" subr-str key-str msg-str rest-str)))
+
+
+
+(provide 'geiser-eval)

elpa/geiser-20171010.1610/geiser-guile.el

@@ -0,0 +1,437 @@
+;; geiser-guile.el -- guile's implementation of the geiser protocols
+
+;; Copyright (C) 2009-2017 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+
+;; 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))
+
+
+;;; Customization:
+
+(defgroup geiser-guile nil
+  "Customization for Geiser's Guile flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-guile-binary
+  (cond ((eq system-type 'windows-nt) "guile.exe")
+        ((eq system-type 'darwin) "guile")
+        (t "guile"))
+  "Name to use to call the Guile executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-load-path nil
+  "A list of paths to be added to Guile's load path when it's started.
+The paths are added to both %load-path and %load-compiled path,
+and only if they are not already present.  This variable is a
+good candidate for an entry in your project's .dir-locals.el."
+  :type '(repeat file)
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-init-file "~/.guile-geiser"
+  "Initialization file with user code for the Guile REPL.
+If all you want is to load ~/.guile, set
+`geiser-guile-load-init-file-p' instead."
+  :type 'string
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-load-init-file-p nil
+  "Whether to load ~/.guile when starting Guile.
+Note that, due to peculiarities in the way Guile loads its init
+file, using `geiser-guile-init-file' is not equivalent to setting
+this variable to t."
+  :type 'boolean
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
+  "Whether to autmatically show a full backtrace when entering the debugger.
+If `nil', only the last frame is shown."
+  :type 'boolean
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
+  "Whether to autmatically jump to error when entering the debugger.
+If `t', Geiser will use `next-error' to jump to the error's location."
+  :type 'boolean
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-show-debug-help-p t
+  "Whether to show brief help in the echo area when entering the debugger."
+  :type 'boolean
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-warning-level 'medium
+  "Verbosity of the warnings reported by Guile.
+
+You can either choose one of the predefined warning sets, or
+provide a list of symbols identifying the ones you want. Possible
+choices are arity-mismatch, unbound-variable, unused-variable and
+unused-toplevel. Unrecognised symbols are ignored.
+
+The predefined levels are:
+
+  - Medium: arity-mismatch, unbound-variable, format
+  - High: arity-mismatch, unbound-variable, unused-variable, format
+  - None: no warnings
+
+Changes to the value of this variable will automatically take
+effect on new REPLs. For existing ones, use the command
+\\[geiser-guile-update-warning-level]."
+  :type '(choice (const :tag "Medium (arity and unbound vars)" medium)
+                 (const :tag "High (also unused vars)" high)
+                 (const :tag "No warnings" none)
+                 (repeat :tag "Custom" symbol))
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-extra-keywords nil
+  "Extra keywords highlighted in Guile scheme buffers."
+  :type '(repeat string)
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-case-sensitive-p t
+  "Non-nil means keyword highlighting is case-sensitive."
+  :type 'boolean
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-manual-lookup-other-window-p nil
+  "Non-nil means pop up the Info buffer in another window."
+  :type 'boolean
+  :group 'geiser-guile)
+
+(geiser-custom--defcustom geiser-guile-manual-lookup-nodes
+                          '("Guile" "guile-2.0")
+  "List of info nodes that, when present, are used for manual lookups"
+  :type '(repeat string)
+  :group 'geiser-guile)
+
+
+;;; REPL support:
+
+(defun geiser-guile--binary ()
+  (if (listp geiser-guile-binary)
+      (car geiser-guile-binary)
+    geiser-guile-binary))
+
+(defun geiser-guile--parameters ()
+  "Return a list with all parameters needed to start Guile.
+This function uses `geiser-guile-init-file' if it exists."
+  (let ((init-file (and (stringp geiser-guile-init-file)
+                        (expand-file-name geiser-guile-init-file)))
+        (q-flags (and (not geiser-guile-load-init-file-p) '("-q"))))
+  `(,@(and (listp geiser-guile-binary) (cdr geiser-guile-binary))
+    ,@q-flags "-L" ,(expand-file-name "guile/" geiser-scheme-dir)
+    ,@(apply 'append (mapcar (lambda (p) (list "-L" p))
+                             geiser-guile-load-path))
+    ,@(and init-file (file-readable-p init-file) (list "-l" init-file)))))
+
+;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
+(defconst geiser-guile--prompt-regexp "[^@()]+@([^)]*?)> ")
+(defconst geiser-guile--debugger-prompt-regexp
+  "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
+
+
+;;; Evaluation support:
+(defsubst geiser-guile--linearize-args (args)
+  (mapconcat 'identity args " "))
+
+(defun geiser-guile--geiser-procedure (proc &rest args)
+  (case proc
+    ((eval compile) (format ",geiser-eval %s %s%s"
+                            (or (car args) "#f")
+                            (geiser-guile--linearize-args (cdr args))
+                            (if (cddr args) "" " ()")))
+    ((load-file compile-file) (format ",geiser-load-file %s" (car args)))
+    ((no-values) ",geiser-no-values")
+    (t (format "ge:%s (%s)" proc (geiser-guile--linearize-args args)))))
+
+(defconst geiser-guile--module-re
+  "(define-module +\\(([^)]+)\\)")
+
+(defconst geiser-guile--library-re
+  "(library +\\(([^)]+)\\)")
+
+(defun geiser-guile--get-module (&optional module)
+  (cond ((null module)
+         (save-excursion
+           (geiser-syntax--pop-to-top)
+           (if (or (re-search-backward geiser-guile--module-re nil t)
+                   (looking-at geiser-guile--library-re)
+                   (re-search-forward geiser-guile--module-re nil t))
+               (geiser-guile--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-guile--module-cmd (module fmt &optional def)
+  (when module
+    (let* ((module (geiser-guile--get-module module))
+           (module (cond ((or (null module) (eq module :f)) def)
+                         (t (format "%s" module)))))
+      (and module (format fmt module)))))
+
+(defun geiser-guile--import-command (module)
+  (geiser-guile--module-cmd module ",use %s"))
+
+(defun geiser-guile--enter-command (module)
+  (geiser-guile--module-cmd module ",m %s" "(guile-user)"))
+
+
+(defun geiser-guile--exit-command () ",q")
+
+(defun geiser-guile--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))))
+
+
+;;; Error display
+
+(defun geiser-guile--enter-debugger ()
+  (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
+                        (if geiser-guile-debug-show-bt-p "bt" "fr"))))
+    (compilation-forget-errors)
+    (goto-char (point-max))
+    (geiser-repl--prepare-send)
+    (comint-send-string nil bt-cmd)
+    (when geiser-guile-show-debug-help-p
+      (message "Debug REPL. Enter ,q to quit, ,h for help."))
+    (when geiser-guile-jump-on-debug-p
+      (accept-process-output (get-buffer-process (current-buffer))
+                             0.2 nil t)
+      (ignore-errors (next-error)))))
+
+(defun geiser-guile--display-error (module key msg)
+  (when (stringp msg)
+    (save-excursion (insert msg))
+    (geiser-edit--buttonize-files))
+  (and (not key) (not (zerop (length msg))) msg))
+
+
+;;; Trying to ascertain whether a buffer is Guile Scheme:
+
+(defconst geiser-guile--guess-re
+  (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
+          geiser-guile--module-re))
+
+(defun geiser-guile--guess ()
+  (save-excursion
+    (goto-char (point-min))
+    (re-search-forward geiser-guile--guess-re nil t)))
+
+
+;;; Keywords and syntax
+
+(defconst geiser-guile--builtin-keywords
+  '("call-with-input-file"
+    "call-with-input-string"
+    "call-with-output-file"
+    "call-with-output-string"
+    "call-with-prompt"
+    "call-with-trace"
+    "define-accessor"
+    "define-class"
+    "define-enumeration"
+    "define-inlinable"
+    "define-syntax-parameter"
+    "eval-when"
+    "lambda*"
+    "syntax-parameterize"
+    "use-modules"
+    "with-error-to-file"
+    "with-error-to-port"
+    "with-error-to-string"
+    "with-fluid*"
+    "with-fluids"
+    "with-fluids*"
+    "with-input-from-port"
+    "with-input-from-string"
+    "with-output-to-port"
+    "with-output-to-string"))
+
+(defun geiser-guile--keywords ()
+  (append
+   (geiser-syntax--simple-keywords geiser-guile-extra-keywords)
+   (geiser-syntax--simple-keywords geiser-guile--builtin-keywords)
+   `((,(rx "(" (group "define-once") eow (* space) (? (group (+ word))))
+       (1 font-lock-keyword-face)
+       (2 font-lock-variable-name-face nil t))
+     ("(\\(define-module\\) +(\\([^)]+\\))"
+      (1 font-lock-keyword-face)
+      (2 font-lock-type-face nil t)))))
+
+(geiser-syntax--scheme-indent
+ (c-declare 0)
+ (c-lambda 2)
+ (call-with-input-string 1)
+ (call-with-output-string 0)
+ (call-with-prompt 1)
+ (call-with-trace 0)
+ (eval-when 1)
+ (lambda* 1)
+ (pmatch defun)
+ (sigaction 1)
+ (syntax-parameterize 1)
+ (with-error-to-file 1)
+ (with-error-to-port 1)
+ (with-error-to-string 0)
+ (with-fluid* 1)
+ (with-fluids 1)
+ (with-fluids* 1)
+ (with-input-from-string 1)
+ (with-method 1)
+ (with-mutex 1)
+ (with-output-to-string 0)
+ (with-throw-handler 1))
+
+
+;;; Compilation shell regexps
+
+(defconst geiser-guile--path-rx "^In \\([^:\n ]+\\):\n")
+
+(defconst geiser-guile--rel-path-rx "^In +\\([^/\n :]+\\):\n")
+
+(defvar geiser-guile--file-cache (make-hash-table :test 'equal))
+
+(defun geiser-guile--resolve-file (file)
+  (when (and (stringp file)
+             (not (member file '("socket" "stdin" "unknown file"))))
+    (if (file-name-absolute-p file) file
+      (or (gethash file geiser-guile--file-cache)
+          (puthash file
+                   (geiser-eval--send/result `(:eval (:ge find-file ,file)))
+                   geiser-guile--file-cache)))))
+
+(defun geiser-guile--resolve-file-x ()
+  (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
+    (and (stringp f) (list f))))
+
+
+;;; REPL startup
+
+(defconst geiser-guile-minimum-version "2.0")
+
+(defun geiser-guile--version (binary)
+  (car (process-lines binary "-c" "(display (version))")))
+
+(defun geiser-guile-update-warning-level ()
+  "Update the warning level used by the REPL.
+The new level is set using the value of `geiser-guile-warning-level'."
+  (interactive)
+  (let ((code `(:eval (:ge set-warnings ',geiser-guile-warning-level)
+                      (geiser evaluation))))
+    (geiser-eval--send/result code)))
+
+(defun connect-to-guile ()
+  "Start a Guile REPL connected to a remote process.
+
+Start the external Guile process with the flag --listen to make
+it spawn a server thread."
+  (interactive)
+  (geiser-connect 'guile))
+
+(defun geiser-guile--set-geiser-load-path ()
+  (let* ((path (expand-file-name "guile/" geiser-scheme-dir))
+         (witness "geiser/emacs.scm")
+         (code `(begin (if (not (%search-load-path ,witness))
+                           (set! %load-path (cons ,path %load-path)))
+                       'done)))
+    (geiser-eval--send/wait code)))
+
+(defun geiser-guile--startup (remote)
+  (set (make-local-variable 'compilation-error-regexp-alist)
+       `((,geiser-guile--path-rx geiser-guile--resolve-file-x)
+         ("^  +\\([0-9]+\\):\\([0-9]+\\)" nil 1 2)))
+  (compilation-setup t)
+  (font-lock-add-keywords nil `((,geiser-guile--path-rx
+                                 1 compilation-error-face)))
+  (let ((geiser-log-verbose-p t))
+    (when remote (geiser-guile--set-geiser-load-path))
+    (geiser-eval--send/wait ",use (geiser emacs)\n'done")
+    (dolist (dir geiser-guile-load-path)
+      (let ((dir (expand-file-name dir)))
+        (geiser-eval--send/wait `(:eval (:ge add-to-load-path ,dir)))))
+    (geiser-guile-update-warning-level)))
+
+
+;;; Manual lookup
+
+(defun geiser-guile--info-spec (&optional nodes)
+  (let* ((nrx "^[ 	]+-+ [^:]+:[ 	]*")
+         (drx "\\b")
+         (res (when (Info-find-file "r5rs" t)
+                `(("(r5rs)Index" nil ,nrx ,drx)))))
+    (dolist (node (or nodes geiser-guile-manual-lookup-nodes) res)
+      (when (Info-find-file node t)
+        (mapc (lambda (idx)
+                (add-to-list 'res
+                             (list (format "(%s)%s" node idx) nil nrx drx)))
+              '("Variable Index" "Procedure Index" "R5RS Index"))))))
+
+
+(info-lookup-add-help :topic 'symbol :mode 'geiser-guile-mode
+                      :ignore-case nil
+                      :regexp "[^()`',\" 	\n]+"
+                      :doc-spec (geiser-guile--info-spec))
+
+(defun guile--manual-look-up (id mod)
+  (let ((info-lookup-other-window-flag
+         geiser-guile-manual-lookup-other-window-p))
+    (info-lookup-symbol (symbol-name id) 'scheme-mode))
+  (when geiser-guile-manual-lookup-other-window-p
+    (switch-to-buffer-other-window "*info*"))
+  (search-forward (format "%s" id) nil t))
+
+
+;;; Implementation definition:
+
+(define-geiser-implementation guile
+  (binary geiser-guile--binary)
+  (arglist geiser-guile--parameters)
+  (version-command geiser-guile--version)
+  (minimum-version geiser-guile-minimum-version)
+  (repl-startup geiser-guile--startup)
+  (prompt-regexp geiser-guile--prompt-regexp)
+  (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp)
+  (enter-debugger geiser-guile--enter-debugger)
+  (marshall-procedure geiser-guile--geiser-procedure)
+  (find-module geiser-guile--get-module)
+  (enter-command geiser-guile--enter-command)
+  (exit-command geiser-guile--exit-command)
+  (import-command geiser-guile--import-command)
+  (find-symbol-begin geiser-guile--symbol-begin)
+  (display-error geiser-guile--display-error)
+  (external-help guile--manual-look-up)
+  (check-buffer geiser-guile--guess)
+  (keywords geiser-guile--keywords)
+  (case-sensitive geiser-guile-case-sensitive-p))
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'guile t)
+
+
+(provide 'geiser-guile)

elpa/geiser-20171010.1610/geiser-image.el

@@ -0,0 +1,121 @@
+;; geiser-image.el -- support for image display
+
+;; Copyright (c) 2012, 2015 Jose Antonio Ortega Ruiz
+
+;; 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>.
+
+;; Authors: Michael Wilber, Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Sep 02, 2012 00:00
+
+
+
+(require 'geiser-custom)
+(require 'geiser-base)
+(require 'geiser-impl)
+
+
+;;; Customization:
+
+(defgroup geiser-image nil
+  "Options for image displaying."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-image-viewer "display"
+  "Which system image viewer program to invoke upon M-x
+`geiser-view-last-image'."
+  :type 'string
+  :group 'geiser-image)
+
+(geiser-custom--defcustom geiser-image-cache-keep-last 10
+  "How many images to keep in geiser's image cache."
+  :type 'integer
+  :group 'geiser-image)
+
+(geiser-custom--defcustom geiser-image-cache-dir nil
+  "Default directory where generated images are stored.
+
+If nil,the system wide tmp dir will be used."
+  :type 'path
+  :group 'geiser-image)
+
+(geiser-custom--defface image-button
+  'button geiser-image "image buttons in terminal buffers")
+
+(geiser-impl--define-caller geiser-image--cache-dir image-cache-dir ()
+  "Directory where generated images are stored.  If this function
+returns nil, no images are generated.")
+
+
+
+(defun geiser-image--list-cache ()
+  "List all the images in the image cache."
+  (let ((cdir (geiser-image--cache-dir nil)))
+    (and cdir
+         (file-directory-p cdir)
+         (let ((files (directory-files-and-attributes cdir t
+                                                      "geiser-img-[0-9]*.png")))
+           (mapcar 'car (sort files (lambda (a b)
+                                      (< (float-time (nth 6 a))
+                                         (float-time (nth 6 b))))))))))
+
+(defun geiser-image--clean-cache ()
+  "Clean all except for the last `geiser-image-cache-keep-last'
+images in `geiser-image--cache-dir'."
+  (interactive)
+  (dolist (f (butlast (geiser-image--list-cache) geiser-image-cache-keep-last))
+    (delete-file f)))
+
+(defun geiser-image--display (file)
+  (start-process "Geiser image view" nil geiser-image-viewer file))
+
+(defun geiser-image--button-action (button)
+  (let ((file (button-get button 'geiser-image-file)))
+    (when (file-exists-p file) (geiser-image--display file))))
+
+(define-button-type 'geiser-image--button
+  'action 'geiser-image--button-action
+  'follow-link t)
+
+(defun geiser-image--insert-button (file)
+  (insert-text-button "[image]"
+                      :type 'geiser-image--button
+                      'face 'geiser-font-lock-image-button
+                      'geiser-image-file file
+                      'help-echo "Click to display image"))
+
+(defun geiser-image--replace-images (inline-images-p auto-p)
+  "Replace all image patterns with actual images"
+  (let ((seen 0))
+    (with-silent-modifications
+      (save-excursion
+        (goto-char (point-min))
+        (while (re-search-forward "\"?#<Image: \\([-+.\\\\/_:0-9a-zA-Z]+\\)>\"?"
+                                  nil t)
+          (setq seen (+ 1 seen))
+          (let* ((file (match-string 1))
+                 (begin (match-beginning 0))
+                 (end (match-end 0)))
+            (delete-region begin end)
+            (goto-char begin)
+            (if (and inline-images-p (display-images-p))
+                (insert-image (create-image file) "[image]")
+              (geiser-image--insert-button file)
+              (when auto-p (geiser-image--display file)))))))
+    seen))
+
+(defun geiser-view-last-image (n)
+  "Open the last displayed image in the system's image viewer.
+
+With prefix arg, open the N-th last shown image in the system's
+image viewer."
+  (interactive "p")
+  (let ((images (reverse (geiser-image--list-cache))))
+    (if (>= (length images) n)
+        (geiser-image--display (nth (- n 1) images))
+      (error "There aren't %d recent images" n))))
+
+
+(provide 'geiser-image)

elpa/geiser-20171010.1610/geiser-impl.el

@@ -0,0 +1,342 @@
+;; geiser-impl.el -- generic support for scheme implementations
+
+;; Copyright (C) 2009, 2010, 2012, 2013, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Mar 07, 2009 23:32
+
+
+
+(require 'geiser-custom)
+(require 'geiser-base)
+
+(require 'help-fns)
+
+
+;;; Customization:
+
+(defgroup geiser-implementation nil
+  "Generic support for multiple Scheme implementations."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-default-implementation nil
+  "Symbol naming the default Scheme implementation."
+  :type 'symbol
+  :group 'geiser-implementation)
+
+(geiser-custom--defcustom geiser-active-implementations
+    '(guile racket chicken chez mit chibi)
+  "List of active installed Scheme implementations."
+  :type '(repeat symbol)
+  :group 'geiser-implementation)
+
+(geiser-custom--defcustom geiser-implementations-alist nil
+  "A map from regular expressions or directories to implementations.
+When opening a new file, its full path will be matched against
+each one of the regular expressions or directories in this map in order to
+determine its scheme flavour."
+  :type '(repeat (list (choice (group :tag "Regular expression"
+                                      (const regexp) regexp)
+                               (group :tag "Directory"
+                                      (const dir) directory))
+                       symbol))
+  :group 'geiser-implementation)
+
+
+;;; Implementation registry:
+
+(defvar geiser-impl--registry nil)
+(defvar geiser-impl--load-files nil)
+(defvar geiser-impl--method-docs nil)
+(defvar geiser-impl--local-methods nil)
+(defvar geiser-impl--local-variables nil)
+
+(geiser-custom--memoize 'geiser-impl--load-files)
+
+(make-variable-buffer-local
+ (defvar geiser-impl--implementation nil))
+
+(defsubst geiser-impl--impl-str (&optional impl)
+  (let ((impl (or impl geiser-impl--implementation)))
+    (and impl (capitalize (format "%s" impl)))))
+
+(defsubst geiser-impl--feature (impl)
+  (intern (format "geiser-%s" impl)))
+
+(defsubst geiser-impl--load-impl (impl)
+  (require (geiser-impl--feature impl)
+           (cdr (assq impl geiser-impl--load-files))
+           t))
+
+(defsubst geiser-impl--methods (impl)
+  (cdr (assq impl geiser-impl--registry)))
+
+(defun geiser-impl--method (method &optional impl)
+  (let ((impl (or impl
+                  geiser-impl--implementation
+                  geiser-default-implementation)))
+    (cadr (assq method (geiser-impl--methods impl)))))
+
+(defun geiser-impl--call-method (method impl &rest args)
+  (let ((fun (geiser-impl--method method impl)))
+    (when (functionp fun) (apply fun args))))
+
+(defun geiser-impl--method-doc (method doc user)
+  (let* ((user (if user (format " Used via `%s'." user) ""))
+         (extra-doc (format "%s%s" doc user)))
+    (add-to-list 'geiser-impl--method-docs (cons method extra-doc))
+    (setq geiser-impl--method-docs
+          (sort geiser-impl--method-docs
+                (lambda (a b) (string< (symbol-name (car a))
+                                  (symbol-name (car b))))))
+    (put method 'function-documentation doc)))
+
+(defun geiser-implementation-help ()
+  "Shows a buffer with help on defining new supported Schemes."
+  (interactive)
+  (help-setup-xref (list #'geiser-implementation-help) t)
+  (save-excursion
+    (with-help-window (help-buffer)
+      (princ "Geiser: supporting new Scheme implementations.\n\n")
+      (princ "Use `define-geiser-implementation' to define ")
+      (princ "new implementations")
+      (princ "\n\n  (define-geiser-implementation NAME &rest METHODS)\n\n")
+      (princ (documentation 'define-geiser-implementation))
+      (princ "\n\nMethods used to define an implementation:\n\n")
+      (dolist (m geiser-impl--method-docs)
+        (let ((p (with-current-buffer (help-buffer) (point))))
+          (princ (format "%s: " (car m)))
+          (princ (cdr m))
+          (with-current-buffer (help-buffer)
+            (fill-region-as-paragraph p (point)))
+          (princ "\n\n")))
+      (with-current-buffer standard-output (buffer-string)))))
+
+(defun geiser-impl--register-local-method (var-name method fallback doc)
+  (add-to-list 'geiser-impl--local-methods (list var-name method fallback))
+  (geiser-impl--method-doc method doc var-name)
+  (put var-name 'function-documentation doc))
+
+(defun geiser-impl--register-local-variable (var-name method fallback doc)
+  (add-to-list 'geiser-impl--local-variables (list var-name method fallback))
+  (geiser-impl--method-doc method doc var-name)
+  (put var-name 'variable-documentation doc))
+
+(defmacro geiser-impl--define-caller (fun-name method arglist doc)
+  (let ((impl (make-symbol "implementation-name")))
+    `(progn
+       (defun ,fun-name ,(cons impl arglist) ,doc
+         (geiser-impl--call-method ',method ,impl ,@arglist))
+       (geiser-impl--method-doc ',method ,doc ',fun-name))))
+(put 'geiser-impl--define-caller 'lisp-indent-function 3)
+
+(defun geiser-impl--register (file impl methods)
+  (let ((current (assq impl geiser-impl--registry)))
+    (if current (setcdr current methods)
+      (push (cons impl methods) geiser-impl--registry))
+    (push (cons impl file) geiser-impl--load-files)))
+
+(defsubst geiser-activate-implementation (impl)
+  (add-to-list 'geiser-active-implementations impl))
+
+(defsubst geiser-deactivate-implementation (impl)
+  (setq geiser-active-implementations
+        (delq impl geiser-active-implementations)))
+
+(defsubst geiser-impl--active-p (impl)
+  (memq impl geiser-active-implementations))
+
+
+;;; Defining implementations:
+
+(defun geiser-impl--normalize-method (m)
+  (when (and (listp m)
+             (= 2 (length m))
+             (symbolp (car m)))
+    (if (functionp (cadr m)) m
+      `(,(car m) (lambda (&rest args) ,(cadr m))))))
+
+(defun geiser-impl--define (file name parent methods)
+  (let* ((methods (mapcar 'geiser-impl--normalize-method methods))
+         (methods (delq nil methods))
+         (inherited-methods (and parent (geiser-impl--methods parent)))
+         (methods (append methods
+                          (dolist (m methods inherited-methods)
+                            (setq inherited-methods
+                                  (assq-delete-all m inherited-methods))))))
+    (geiser-impl--register file name methods)))
+
+(defmacro define-geiser-implementation (name &rest methods)
+  "Defines a new supported Scheme implementation.
+NAME can be either an unquoted symbol naming the implementation,
+or a two-element list (NAME PARENT), with PARENT naming another
+registered implementation from which to borrow methods not
+defined in METHODS.
+
+After NAME come the methods, each one a two element list of the
+form (METHOD-NAME FUN-OR-VAR), where METHOD-NAME is one of the
+needed methods (for a list, execute `geiser-implementation-help')
+and a value, variable name or function name implementing it.
+Omitted method names will return nil to their callers.
+
+Here's how a typical call to this macro looks like:
+
+  (define-geiser-implementation guile
+    (binary geiser-guile--binary)
+    (arglist geiser-guile--parameters)
+    (repl-startup geiser-guile--startup)
+    (prompt-regexp geiser-guile--prompt-regexp)
+    (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp)
+    (enter-debugger geiser-guile--enter-debugger)
+    (marshall-procedure geiser-guile--geiser-procedure)
+    (find-module geiser-guile--get-module)
+    (enter-command geiser-guile--enter-command)
+    (exit-command geiser-guile--exit-command)
+    (import-command geiser-guile--import-command)
+    (find-symbol-begin geiser-guile--symbol-begin)
+    (display-error geiser-guile--display-error)
+    (display-help)
+    (check-buffer geiser-guile--guess)
+    (keywords geiser-guile--keywords)
+    (case-sensitive geiser-guile-case-sensitive-p))
+
+This macro also defines a runner function (run-NAME) and a
+switcher (switch-to-NAME), and provides geiser-NAME."
+  (let ((name (if (listp name) (car name) name))
+        (parent (and (listp name) (cadr name))))
+    (unless (symbolp name)
+      (error "Malformed implementation name: %s" name))
+    (let ((runner (intern (format "run-%s" name)))
+          (switcher (intern (format "switch-to-%s" name)))
+          (runner-doc (format "Start a new %s REPL." name))
+          (switcher-doc (format "Switch to a running %s REPL, or start one."
+                                name))
+          (ask (make-symbol "ask")))
+      `(progn
+         (geiser-impl--define ,load-file-name ',name ',parent ',methods)
+         (require 'geiser-repl)
+         (require 'geiser-menu)
+         (defun ,runner ()
+           ,runner-doc
+           (interactive)
+           (run-geiser ',name))
+         (defun ,switcher (&optional ,ask)
+           ,switcher-doc
+           (interactive "P")
+           (switch-to-geiser ,ask ',name))
+         (geiser-menu--add-impl ',name ',runner ',switcher)))))
+
+(defun geiser-impl--add-to-alist (kind what impl &optional append)
+  (add-to-list 'geiser-implementations-alist
+               (list (list kind what) impl) append))
+
+
+;;; Trying to guess the scheme implementation:
+
+(make-variable-buffer-local
+ (defvar geiser-scheme-implementation nil
+   "Set this buffer local variable to specify the Scheme
+implementation to be used by Geiser."))
+
+(put 'geiser-scheme-implementation 'safe-local-variable 'symbolp)
+
+(defun geiser-impl--match-impl (desc bn)
+  (let ((rx (if (eq (car desc) 'regexp)
+                (cadr desc)
+              (format "^%s" (regexp-quote (cadr desc))))))
+    (and rx (string-match-p rx bn))))
+
+(defvar geiser-impl--impl-prompt-history nil)
+
+(defun geiser-impl--read-impl (&optional prompt impls non-req)
+  (let* ((impls (or impls geiser-active-implementations))
+         (impls (mapcar 'symbol-name impls))
+         (prompt (or prompt "Scheme implementation: ")))
+    (intern (completing-read prompt impls nil (not non-req) nil
+                             geiser-impl--impl-prompt-history
+                             (and (car impls) (car impls))))))
+
+(geiser-impl--define-caller geiser-impl--check-buffer check-buffer ()
+  "Method called without arguments that should check whether the current
+buffer contains Scheme code of the given implementation.")
+
+(defun geiser-impl--guess (&optional prompt)
+  (or geiser-impl--implementation
+      (progn (hack-local-variables)
+             (and (memq geiser-scheme-implementation
+                        geiser-active-implementations)
+                  geiser-scheme-implementation))
+      (and (null (cdr geiser-active-implementations))
+           (car geiser-active-implementations))
+      (catch 'impl
+        (dolist (impl geiser-active-implementations)
+          (when (geiser-impl--check-buffer impl)
+            (throw 'impl impl)))
+        (let ((bn (buffer-file-name)))
+          (when bn
+            (dolist (x geiser-implementations-alist)
+              (when (and (memq (cadr x) geiser-active-implementations)
+                         (geiser-impl--match-impl (car x) bn))
+                (throw 'impl (cadr x)))))))
+      geiser-default-implementation
+      (and prompt (geiser-impl--read-impl))))
+
+
+;;; Using implementations:
+
+(defsubst geiser-impl--registered-method (impl method fallback)
+  (let ((m (geiser-impl--method method impl)))
+    (if (fboundp m) m
+      (or fallback (error "%s not defined for %s implementation"
+                          method impl)))))
+
+(defsubst geiser-impl--registered-value (impl method fallback)
+  (let ((m (geiser-impl--method method impl)))
+    (if (functionp m) (funcall m) fallback)))
+
+(defun geiser-impl--set-buffer-implementation (&optional impl prompt)
+  (let ((impl (or impl (geiser-impl--guess prompt))))
+    (when impl
+      (unless (geiser-impl--load-impl impl)
+        (error "Cannot find %s implementation" impl))
+      (setq geiser-impl--implementation impl)
+      (dolist (m geiser-impl--local-methods)
+        (set (make-local-variable (nth 0 m))
+             (geiser-impl--registered-method impl (nth 1 m) (nth 2 m))))
+      (dolist (m geiser-impl--local-variables)
+        (set (make-local-variable (nth 0 m))
+             (geiser-impl--registered-value impl (nth 1 m) (nth 2 m)))))))
+
+(defmacro with--geiser-implementation (impl &rest body)
+  (let* ((mbindings (mapcar (lambda (m)
+                              `(,(nth 0 m)
+                                (geiser-impl--registered-method ,impl
+                                                                ',(nth 1 m)
+                                                                ',(nth 2 m))))
+                            geiser-impl--local-methods))
+         (vbindings (mapcar (lambda (m)
+                              `(,(nth 0 m)
+                                (geiser-impl--registered-value ,impl
+                                                               ',(nth 1 m)
+                                                               ',(nth 2 m))))
+                            geiser-impl--local-variables))
+         (ibindings `((geiser-impl--implementation ,impl)))
+         (bindings (append ibindings mbindings vbindings)))
+    `(let* ,bindings ,@body)))
+(put 'with--geiser-implementation 'lisp-indent-function 1)
+
+
+;;; Reload support:
+
+(defun geiser-impl-unload-function ()
+  (dolist (imp (mapcar (lambda (i)
+                         (geiser-impl--feature (car i)))
+                       geiser-impl--registry))
+    (when (featurep imp) (unload-feature imp t))))
+
+
+(provide 'geiser-impl)

elpa/geiser-20171010.1610/geiser-log.el

@@ -0,0 +1,108 @@
+;; geiser-log.el -- logging utilities
+
+;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Feb 07, 2009 12:07
+
+
+
+;; Some utilities for maintaining a simple log buffer, mainly for
+;; debugging purposes.
+
+(require 'geiser-popup)
+(require 'geiser-base)
+
+(require 'comint)
+
+
+;;; Customization:
+
+(defvar geiser-log--buffer-name "*geiser messages*"
+  "Name of the Geiser log buffer.")
+
+(defvar geiser-log--max-buffer-size 32000
+  "Maximum size of the Geiser messages log.")
+
+(defvar geiser-log--max-message-size 2048
+  "Maximum size of individual Geiser log messages.")
+
+(defvar geiser-log-verbose-p nil
+  "Log purely informational messages. Useful for debugging.")
+
+(defvar geiser-log--inhibit-p nil
+  "Set this to t to inhibit all log messages")
+
+
+;;; Log buffer and mode:
+
+(define-derived-mode geiser-messages-mode fundamental-mode "Geiser Messages"
+  "Simple mode for Geiser log messages buffer."
+  (buffer-disable-undo)
+  (add-hook 'after-change-functions
+            '(lambda (b e len)
+               (let ((inhibit-read-only t))
+                 (when (> b geiser-log--max-buffer-size)
+                   (delete-region (point-min) b))))
+            nil t)
+  (setq buffer-read-only t))
+
+(geiser-popup--define log geiser-log--buffer-name geiser-messages-mode)
+
+
+;;; Logging functions:
+
+(defun geiser-log--msg (type &rest args)
+  (unless geiser-log--inhibit-p
+    (geiser-log--with-buffer
+      (goto-char (point-max))
+      (insert (geiser--shorten-str (format "\n%s: %s\n" type
+                                           (apply 'format args))
+                                   geiser-log--max-message-size)))))
+
+(defsubst geiser-log--warn (&rest args)
+  (apply 'geiser-log--msg 'WARNING args))
+
+(defsubst geiser-log--error (&rest args)
+  (apply 'geiser-log--msg 'ERROR args))
+
+(defsubst geiser-log--info (&rest args)
+  (when geiser-log-verbose-p
+    (apply 'geiser-log--msg 'INFO args) ""))
+
+
+;;; User commands:
+
+(defun geiser-show-logs (&optional arg)
+  "Show Geiser log messages.
+With prefix, activates all logging levels."
+  (interactive "P")
+  (when arg (setq geiser-log-verbose-p t))
+  (geiser-log--pop-to-buffer))
+
+(defun geiser-log-clear ()
+  "Clean all logs."
+  (interactive)
+  (geiser-log--with-buffer (delete-region (point-min) (point-max))))
+
+(defun geiser-log-toggle-verbose ()
+  "Toggle verbose logs"
+  (interactive)
+  (setq geiser-log-verbose-p (not geiser-log-verbose-p))
+  (message "Geiser verbose logs %s"
+           (if geiser-log-verbose-p "enabled" "disabled")))
+
+(defun geiser-log--deactivate ()
+  (interactive)
+  (setq geiser-log-verbose-p nil)
+  (when (eq (current-buffer) (geiser-log--buffer)) (View-quit)))
+
+(define-key geiser-messages-mode-map "c" 'geiser-log-clear)
+(define-key geiser-messages-mode-map "Q" 'geiser-log--deactivate)
+
+
+(provide 'geiser-log)

elpa/geiser-20171010.1610/geiser-menu.el

@@ -0,0 +1,143 @@
+;;; geiser-menu.el -- menu and keymaps definition
+
+;; Copyright (c) 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Jun 12, 2010 03:01
+
+
+(require 'geiser-custom)
+(require 'geiser-base)
+
+
+;;; Customization:
+
+(geiser-custom--defcustom geiser-global-menu-always-on-p nil
+   "Whether the Geiser menu is always visible."
+   :type 'boolean
+   :group 'geiser)
+
+
+;;; Top-level menu
+
+(defmacro geiser-menu--add-item (keymap map kd)
+  (cond ((or (eq '-- kd) (eq 'line kd)) `(geiser-menu--add-line ,map))
+        ((stringp (car kd)) `(geiser-menu--add-basic-item ,keymap ,map ,kd))
+        ((eq 'menu (car kd)) `(geiser-menu--add-submenu ,(cadr kd)
+                                ,keymap ,map ,(cddr kd)))
+        ((eq 'custom (car kd)) `(geiser-menu--add-custom ,(nth 1 kd)
+                                                         ,(nth 2 kd)
+                                                         ,keymap
+                                                         ,map))
+        ((eq 'mode (car kd)) `(geiser-menu--mode-toggle ,(nth 1 kd)
+                                                        ,(nth 2 kd)
+                                                        ,(nth 3 kd)
+                                                        ,keymap
+                                                        ,map))
+        (t (error "Bad item form: %s" kd))))
+
+(defmacro geiser-menu--add-basic-item (keymap map kd)
+  (let* ((title (nth 0 kd))
+         (binding (nth 1 kd))
+         (cmd (nth 2 kd))
+         (hlp (nth 3 kd))
+         (item (make-symbol title))
+         (hlp (and (stringp hlp) (list :help hlp)))
+         (rest (or (and hlp (nthcdr 4 kd))
+                   (nthcdr 3 kd)))
+         (binding (if (listp binding)
+                      binding
+                    (list binding))))
+    `(progn (define-key ,map [,item]
+              '(menu-item ,title ,cmd ,@hlp ,@rest))
+            ,@(and (car binding)
+                   `((put ',cmd
+                          :advertised-binding
+                          ,(car binding))))
+            ,@(mapcar (lambda (b)
+                        `(define-key ,keymap ,b ',cmd))
+                      binding))))
+
+(defmacro geiser-menu--add-items (keymap map keys)
+  `(progn ,@(mapcar (lambda (k) (list 'geiser-menu--add-item keymap map k))
+                    (reverse keys))))
+
+(defmacro geiser-menu--add-submenu (name keymap map keys)
+  (let ((ev (make-symbol name))
+        (map2 (make-symbol "map2")))
+    `(progn
+       (let ((,map2 (make-sparse-keymap ,name)))
+         (define-key ,map [,ev] (cons ,name ,map2))
+         (geiser-menu--add-items ,keymap ,map2 ,keys)))))
+
+(defvar geiser-menu--line-counter 0)
+
+(defun geiser-menu--add-line (&optional map)
+  (let ((line (make-symbol (format "line%s"
+                                   (setq geiser-menu--line-counter
+                                         (1+ geiser-menu--line-counter))))))
+    (define-key (or map global-map) `[,line]
+      `(menu-item "--single-line"))))
+
+(defmacro geiser-menu--add-custom (title group keymap map)
+  `(geiser-menu--add-item ,keymap ,map
+     (,title nil (lambda () (interactive) (customize-group ',group)))))
+
+(defmacro geiser-menu--mode-toggle (title bindings mode keymap map)
+  `(geiser-menu--add-item ,keymap ,map
+     (,title ,bindings ,mode
+             :button (:toggle . (and (boundp ',mode) ,mode)))))
+
+(defmacro geiser-menu--defmenu (name keymap &rest keys)
+  (let ((mmap (make-symbol "mmap")))
+    `(progn
+       (let ((,mmap (make-sparse-keymap "Geiser")))
+         (define-key ,keymap [menu-bar ,name] (cons "Geiser" ,mmap))
+         (define-key ,mmap [customize]
+           (cons "Customize" geiser-menu--custom-customize))
+         (define-key ,mmap [switch]
+           (cons "Switch to" geiser-menu--custom-switch))
+         (define-key ,mmap [Run] (cons "Run" geiser-menu--custom-run))
+         (geiser-menu--add-line ,mmap)
+         (geiser-menu--add-items ,keymap ,mmap ,keys)
+         ,mmap))))
+
+(put 'geiser-menu--defmenu 'lisp-indent-function 2)
+
+
+;;; Shared entries
+
+(defvar geiser-menu--custom-map (make-sparse-keymap "Geiser"))
+(defvar geiser-menu--custom-run (make-sparse-keymap "Run"))
+(defvar geiser-menu--custom-switch (make-sparse-keymap "Switch"))
+(defvar geiser-menu--custom-customize (make-sparse-keymap "Customize"))
+
+(define-key geiser-menu--custom-map [customize]
+  (cons "Customize" geiser-menu--custom-customize))
+(define-key geiser-menu--custom-map [switch]
+  (cons "Switch to" geiser-menu--custom-switch))
+(define-key geiser-menu--custom-map [run]
+  (cons "Run" geiser-menu--custom-run))
+
+(defun geiser-menu--add-global-custom (title group)
+  (define-key geiser-menu--custom-customize `[,(make-symbol title)]
+    (cons title `(lambda () (interactive) (customize-group ',group)))))
+
+(defun geiser-menu--add-impl (name runner switcher)
+  (let ((title (capitalize (format "%s" name)))
+        (group (intern (format "geiser-%s" name))))
+    (define-key geiser-menu--custom-run `[,name]
+      `(menu-item ,title ,runner :enable (geiser-impl--active-p ',name)))
+    (define-key geiser-menu--custom-switch `[,name]
+      `(menu-item ,title ,switcher :enable (geiser-repl--repl/impl ',name)))
+    (geiser-menu--add-global-custom title group)))
+
+(geiser-menu--add-global-custom "Geiser" 'geiser)
+
+
+
+(provide 'geiser-menu)

elpa/geiser-20171010.1610/geiser-mit.el

@@ -0,0 +1,165 @@
+;; 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)
+(require 'subr-x)
+
+(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 'directory
+  :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.1.1")
+
+(defun geiser-mit--version (binary)
+  (car (process-lines binary
+                      "--quiet"
+                      "--no-init-file"
+                      "--eval"
+                      "(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)

elpa/geiser-20171010.1610/geiser-mode.el

@@ -0,0 +1,456 @@
+;; geiser-mode.el -- minor mode for scheme buffers
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Jose Antonio Ortega Ruiz
+
+;; 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 Feb 08, 2009 15:13
+
+
+
+(require 'geiser-repl)
+(require 'geiser-menu)
+(require 'geiser-doc)
+(require 'geiser-compile)
+(require 'geiser-completion)
+(require 'geiser-company)
+(require 'geiser-xref)
+(require 'geiser-edit)
+(require 'geiser-autodoc)
+(require 'geiser-debug)
+(require 'geiser-syntax)
+(require 'geiser-impl)
+(require 'geiser-eval)
+(require 'geiser-popup)
+(require 'geiser-custom)
+(require 'geiser-base)
+
+
+;;; Customization:
+
+(defgroup geiser-mode nil
+  "Mode enabling Geiser abilities in Scheme buffers &co.."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-mode-auto-p t
+  "Whether `geiser-mode' should be active by default in all scheme buffers."
+  :group 'geiser-mode
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-mode-start-repl-p nil
+  "Whether a REPL should be automatically started if one is not
+active when `geiser-mode' is activated in a buffer."
+  :group 'geiser-mode
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-mode-autodoc-p t
+  "Whether `geiser-autodoc-mode' gets enabled by default in Scheme buffers."
+  :group 'geiser-mode
+  :group 'geiser-autodoc
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-mode-company-p t
+  "Whether to use company-mode for completion, if available."
+  :group 'geiser-mode
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-mode-smart-tab-p nil
+  "Whether `geiser-smart-tab-mode' gets enabled by default in Scheme buffers."
+  :group 'geiser-mode
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-mode-eval-last-sexp-to-buffer nil
+  "Whether `eval-last-sexp' prints results to buffer"
+  :group 'geiser-mode
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-mode-eval-to-buffer-prefix " "
+  "When `geiser-mode-eval-last-sexp-to-buffer', the prefix string
+which will be prepended to results."
+  :group 'geiser-mode
+  :type 'string)
+
+(geiser-custom--defcustom geiser-mode-eval-to-buffer-transformer nil
+  "Transformer for results inserted in debug buffer.
+
+When `geiser-mode-eval-last-sexp-to-buffer', the result will be
+transformed using this function default behavior is just prepend
+with `geiser-mode-eval-to-buffer-prefix' takes two arguments:
+`msg' and `is-error?'  `msg' is the result string going to be
+transformed, `is-error?' is a boolean indicating whether the
+result is an error msg."
+  :group 'geiser-mode
+  :type 'function)
+
+
+
+;;; Evaluation commands:
+
+(defun geiser--go-to-repl ()
+  (switch-to-geiser nil nil (current-buffer))
+  (push-mark)
+  (goto-char (point-max)))
+
+(defun geiser-eval-region (start end &optional and-go raw nomsg)
+  "Eval the current region in the Geiser REPL.
+
+With prefix, goes to the REPL buffer afterwards (as
+`geiser-eval-region-and-go')"
+  (interactive "rP")
+  (save-restriction
+    (narrow-to-region start end)
+    (check-parens))
+  (geiser-debug--send-region nil
+                             start
+                             end
+                             (and and-go 'geiser--go-to-repl)
+                             (not raw)
+                             nomsg))
+
+(defun geiser-eval-region-and-go (start end)
+  "Eval the current region in the Geiser REPL and visit it afterwads."
+  (interactive "r")
+  (geiser-eval-region start end t))
+
+(geiser-impl--define-caller geiser-eval--bounds eval-bounds ()
+  "A pair with the bounds of a buffer to be evaluated, defaulting
+  to (cons (point-min) . (point-max)).")
+
+(defun geiser-eval-buffer (&optional and-go raw nomsg)
+  "Eval the current buffer in the Geiser REPL.
+
+With prefix, goes to the REPL buffer afterwards (as
+`geiser-eval-buffer-and-go')"
+  (interactive "P")
+  (let* ((bounds (geiser-eval--bounds geiser-impl--implementation))
+         (from (or (car bounds) (point-min)))
+         (to (or (cdr bounds) (point-max))))
+    (geiser-eval-region from to and-go raw nomsg)))
+
+(defun geiser-eval-buffer-and-go ()
+  "Eval the current buffer in the Geiser REPL and visit it afterwads."
+  (interactive)
+  (geiser-eval-buffer t))
+
+(defun geiser-eval-definition (&optional and-go)
+  "Eval the current definition in the Geiser REPL.
+
+With prefix, goes to the REPL buffer afterwards (as
+`geiser-eval-definition-and-go')"
+  (interactive "P")
+  (save-excursion
+    (end-of-defun)
+    (let ((end (point)))
+      (beginning-of-defun)
+      (geiser-eval-region (point) end and-go t))))
+
+(defun geiser-eval-definition-and-go ()
+  "Eval the current definition in the Geiser REPL and visit it afterwads."
+  (interactive)
+  (geiser-eval-definition t))
+
+(defun geiser-eval-last-sexp (print-to-buffer-p)
+  "Eval the previous sexp in the Geiser REPL.
+
+With a prefix, revert the effect of `geiser-mode-eval-last-sexp-to-buffer' "
+  (interactive "P")
+  (let* (bosexp
+         (eosexp (save-excursion (backward-sexp)
+                                 (setq bosexp (point))
+                                 (forward-sexp)
+                                 (point)))
+	 (ret-transformer (or geiser-mode-eval-to-buffer-transformer
+			      (lambda (msg is-error?)
+				(format "%s%s%s"
+                                        geiser-mode-eval-to-buffer-prefix
+					(if is-error? "ERROR" "")
+                                        msg))))
+         (ret (save-excursion
+                (geiser-eval-region bosexp ;beginning of sexp
+                                    eosexp ;end of sexp
+                                    nil
+                                    t
+                                    print-to-buffer-p)))
+	 (err (geiser-eval--retort-error ret))
+	 (will-eval-to-buffer (if print-to-buffer-p
+				  (not geiser-mode-eval-last-sexp-to-buffer)
+				geiser-mode-eval-last-sexp-to-buffer))
+	 (str (geiser-eval--retort-result-str ret
+                                              (when will-eval-to-buffer ""))))
+    (cond  ((not will-eval-to-buffer) str)
+	   (err (insert (funcall ret-transformer
+                                 (geiser-eval--error-str err) t)))
+	   ((string= "" str))
+	   (t (push-mark)
+              (insert (funcall ret-transformer str nil))))))
+
+(defun geiser-compile-definition (&optional and-go)
+  "Compile the current definition in the Geiser REPL.
+
+With prefix, goes to the REPL buffer afterwards (as
+`geiser-eval-definition-and-go')"
+  (interactive "P")
+  (save-excursion
+    (end-of-defun)
+    (let ((end (point)))
+      (beginning-of-defun)
+      (geiser-debug--send-region t
+                                 (point)
+                                 end
+                                 (and and-go 'geiser--go-to-repl)
+                                 t))))
+
+(defun geiser-compile-definition-and-go ()
+  "Compile the current definition in the Geiser REPL and visit it afterwads."
+  (interactive)
+  (geiser-compile-definition t))
+
+(defun geiser-expand-region (start end &optional all raw)
+  "Macro-expand the current region and display it in a buffer.
+With prefix, recursively macro-expand the resulting expression."
+  (interactive "rP")
+  (geiser-debug--expand-region start end all (not raw)))
+
+(defun geiser-expand-definition (&optional all)
+  "Macro-expand the current definition.
+
+With prefix, recursively macro-expand the resulting expression."
+  (interactive "P")
+  (save-excursion
+    (end-of-defun)
+    (let ((end (point)))
+      (beginning-of-defun)
+      (geiser-expand-region (point) end all t))))
+
+(defun geiser-expand-last-sexp (&optional all)
+  "Macro-expand the previous sexp.
+
+With prefix, recursively macro-expand the resulting expression."
+  (interactive "P")
+  (geiser-expand-region (save-excursion (backward-sexp) (point))
+                        (point)
+                        all
+                        t))
+
+(defun geiser-set-scheme ()
+  "Associates current buffer with a given Scheme implementation."
+  (interactive)
+  (geiser-syntax--remove-kws)
+  (let ((impl (geiser-impl--read-impl)))
+    (geiser-impl--set-buffer-implementation impl)
+    (geiser-repl--set-up-repl impl)
+    (geiser-syntax--add-kws)
+    (geiser-syntax--fontify)))
+
+(defun geiser-mode-switch-to-repl (arg)
+  "Switches to Geiser REPL.
+
+With prefix, try to enter the current buffer's module."
+  (interactive "P")
+  (if arg
+      (switch-to-geiser-module (geiser-eval--get-module) (current-buffer))
+    (switch-to-geiser nil nil (current-buffer))))
+
+(defun geiser-mode-switch-to-repl-and-enter ()
+  "Switches to Geiser REPL and enters current buffer's module."
+  (interactive)
+  (geiser-mode-switch-to-repl t))
+
+(defun geiser-restart-repl ()
+  "Restarts the REPL associated with the current buffer."
+  (interactive)
+  (let ((b (current-buffer)))
+    (geiser-mode-switch-to-repl nil)
+    (comint-kill-subjob)
+    (sit-for 0.1) ;; ugly hack; but i don't care enough to fix it
+    (call-interactively 'run-geiser)
+    (sit-for 0.2) ;; ditto
+    (goto-char (point-max))
+    (pop-to-buffer b)))
+
+(defun geiser-squarify (n)
+  "Toggle between () and [] for current form.
+
+With numeric prefix, perform that many toggles, forward for
+positive values and backward for negative."
+  (interactive "p")
+  (let ((pared (and (boundp 'paredit-mode) paredit-mode))
+        (fwd (> n 0))
+        (steps (abs n)))
+    (when (and pared (fboundp 'paredit-mode)) (paredit-mode -1))
+    (unwind-protect
+        (save-excursion
+          (unless (looking-at-p "\\s(") (backward-up-list))
+          (while (> steps 0)
+            (let ((p (point))
+                  (round (looking-at-p "(")))
+              (forward-sexp)
+              (backward-delete-char 1)
+              (insert (if round "]" ")"))
+              (goto-char p)
+              (delete-char 1)
+              (insert (if round "[" "("))
+              (setq steps (1- steps))
+              (backward-char)
+              (condition-case nil
+                  (progn (when fwd (forward-sexp 2))
+                         (backward-sexp))
+                (error (setq steps 0))))))
+      (when (and pared (fboundp 'paredit-mode)) (paredit-mode 1)))))
+
+(defun geiser-insert-lambda (&optional full)
+  "Insert λ at point.  With prefix, inserts (λ ())."
+  (interactive "P")
+  (if (not full)
+      (insert (make-char 'greek-iso8859-7 107))
+    (insert "(" (make-char 'greek-iso8859-7 107) " ())")
+    (backward-char 2)))
+
+
+;;; Geiser mode:
+
+(make-variable-buffer-local
+ (defvar geiser-mode-string nil
+   "Modeline indicator for geiser-mode"))
+
+(defun geiser-mode--lighter ()
+  (or geiser-mode-string
+      (format " %s" (or (geiser-impl--impl-str) "G"))))
+
+(defvar geiser-mode-map (make-sparse-keymap))
+
+(define-minor-mode geiser-mode
+  "Toggle Geiser's mode.
+
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When Geiser mode is enabled, a host of nice utilities for
+interacting with the Geiser REPL is at your disposal.
+\\{geiser-mode-map}"
+  :init-value nil
+  :lighter (:eval (geiser-mode--lighter))
+  :group 'geiser-mode
+  :keymap geiser-mode-map
+  (when geiser-mode (geiser-impl--set-buffer-implementation nil t))
+  (setq geiser-autodoc-mode-string "/A")
+  (setq geiser-smart-tab-mode-string "/T")
+  (geiser-company--setup (and geiser-mode geiser-mode-company-p))
+  (geiser-completion--setup geiser-mode)
+  (when geiser-mode-autodoc-p
+    (geiser-autodoc-mode (if geiser-mode 1 -1)))
+  (when geiser-mode-smart-tab-p
+    (geiser-smart-tab-mode (if geiser-mode 1 -1)))
+  (geiser-syntax--add-kws)
+  (when (and geiser-mode
+             geiser-mode-start-repl-p
+             (not (geiser-syntax--font-lock-buffer-p))
+             (not (geiser-repl--connection*)))
+    (save-window-excursion (run-geiser geiser-impl--implementation))))
+
+(defun turn-on-geiser-mode ()
+  "Enable `geiser-mode' (in a Scheme buffer)."
+  (interactive)
+  (geiser-mode 1))
+
+(defun turn-off-geiser-mode ()
+  "Disable `geiser-mode' (in a Scheme buffer)."
+  (interactive)
+  (geiser-mode -1))
+
+(defun geiser-mode--maybe-activate ()
+  (when (and geiser-mode-auto-p (eq major-mode 'scheme-mode))
+    (turn-on-geiser-mode)))
+
+
+;;; Keys:
+
+(geiser-menu--defmenu geiserm geiser-mode-map
+  ("Eval sexp before point" "\C-x\C-e" geiser-eval-last-sexp)
+  ("Eval definition" ("\M-\C-x" "\C-c\C-c") geiser-eval-definition)
+  ("Eval definition and go" ("\C-c\M-e" "\C-c\M-e")
+   geiser-eval-definition-and-go)
+  ("Eval region" "\C-c\C-r" geiser-eval-region :enable mark-active)
+  ("Eval region and go" "\C-c\M-r" geiser-eval-region-and-go
+   geiser-eval-region :enable mark-active)
+  ("Eval buffer" "\C-c\C-b" geiser-eval-buffer)
+  ("Eval buffer and go" "\C-c\M-b" geiser-eval-buffer-and-go)
+  ("Load scheme file..." "\C-c\C-l" geiser-load-file)
+  (menu "Macroexpand"
+        ("Sexp before point" ("\C-c\C-m\C-e" "\C-c\C-me")
+         geiser-expand-last-sexp)
+        ("Region" ("\C-c\C-m\C-r" "\C-c\C-mr") geiser-expand-region)
+        ("Definition" ("\C-c\C-m\C-x" "\C-c\C-mx") geiser-expand-definition))
+  --
+  ("Symbol documentation" ("\C-c\C-d\C-d" "\C-c\C-dd")
+   geiser-doc-symbol-at-point :enable (geiser--symbol-at-point))
+  ("Short symbol documentation" ("\C-c\C-d\C-s" "\C-c\C-ds")
+   geiser-autodoc-show :enable (geiser--symbol-at-point))
+  ("Module documentation" ("\C-c\C-d\C-m" "\C-c\C-dm") geiser-doc-module)
+  ("Symbol manual lookup" ("\C-c\C-d\C-i" "\C-c\C-di")
+   geiser-doc-look-up-manual :enable (geiser-doc--manual-available-p))
+  (mode "Autodoc mode" ("\C-c\C-d\C-a" "\C-c\C-da") geiser-autodoc-mode)
+  --
+  ("Compile buffer" "\C-c\C-k" geiser-compile-current-buffer)
+  ("Switch to REPL" "\C-c\C-z" geiser-mode-switch-to-repl)
+  ("Switch to REPL and enter module" "\C-c\C-a"
+   geiser-mode-switch-to-repl-and-enter)
+  ("Set Scheme..." "\C-c\C-s" geiser-set-scheme)
+  --
+  ("Edit symbol at point" "\M-." geiser-edit-symbol-at-point
+   :enable (geiser--symbol-at-point))
+  ("Go to previous definition" "\M-," geiser-pop-symbol-stack)
+  ("Complete symbol" ((kbd "M-TAB")) completion-at-point
+   :enable (geiser--symbol-at-point))
+  ("Complete module name" ((kbd "M-`") (kbd "C-."))
+   geiser-completion--complete-module)
+  ("Edit module" ("\C-c\C-e\C-m" "\C-c\C-em") geiser-edit-module)
+  ("Add to load path..." ("\C-c\C-e\C-l" "\C-c\C-el") geiser-add-to-load-path)
+  ("Toggle ()/[]" ("\C-c\C-e\C-[" "\C-c\C-e[") geiser-squarify)
+  ("Insert λ" ("\C-c\\" "\C-c\C-\\") geiser-insert-lambda)
+  --
+  ("Callers" ((kbd "C-c <")) geiser-xref-callers
+   :enable (and (geiser-eval--supported-p 'callers)
+                (geiser--symbol-at-point)))
+  ("Callees" ((kbd "C-c >")) geiser-xref-callees
+   :enable (and (geiser-eval--supported-p 'callees)
+                (geiser--symbol-at-point)))
+  --
+  (mode "Smart TAB mode" nil geiser-smart-tab-mode)
+  --
+  (custom "Customize Geiser mode" geiser-mode))
+
+(define-key geiser-mode-map [menu-bar scheme] 'undefined)
+
+;; (geiser-mode--triple-chord ?x ?m 'geiser-xref-generic-methods)
+
+
+;;; Reload support:
+
+(defun geiser-mode--buffers ()
+  (let ((buffers))
+    (dolist (buffer (buffer-list))
+      (when (buffer-live-p buffer)
+        (set-buffer buffer)
+        (when geiser-mode
+          (push (cons buffer geiser-impl--implementation) buffers))))
+    buffers))
+
+(defun geiser-mode--restore (buffers)
+  (dolist (b buffers)
+    (when (buffer-live-p (car b))
+      (set-buffer (car b))
+      (when (cdr b)
+        (geiser-impl--set-buffer-implementation (cdr b)))
+      (geiser-mode 1))))
+
+(defun geiser-mode-unload-function ()
+  (dolist (b (geiser-mode--buffers))
+    (with-current-buffer (car b) (geiser-mode nil))))
+
+
+(provide 'geiser-mode)

elpa/geiser-20171010.1610/geiser-pkg.el

@@ -0,0 +1,4 @@
+(define-package "geiser" "20171010.1610" "GNU Emacs and Scheme talk to each other" 'nil :url "http://www.nongnu.org/geiser/")
+;; Local Variables:
+;; no-byte-compile: t
+;; End:

elpa/geiser-20171010.1610/geiser-popup.el

@@ -0,0 +1,70 @@
+;; geiser-popup.el -- popup windows
+
+;; Copyright (C) 2009, 2010, 2012, 2013 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Feb 07, 2009 14:05
+
+(require 'view)
+
+
+;;; Support for defining popup buffers and accessors:
+
+(defvar geiser-popup--registry nil)
+
+(defvar geiser-popup--overriding-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map "q" 'View-quit)
+    map))
+
+(defun geiser-popup--setup-view-mode ()
+  (view-mode t)
+  (set (make-local-variable 'view-no-disable-on-exit) t)
+  (set (make-local-variable 'minor-mode-overriding-map-alist)
+       (list (cons 'view-mode geiser-popup--overriding-map)))
+  (setq view-exit-action
+	(lambda (buffer)
+	  (with-current-buffer buffer
+	    (bury-buffer)))))
+
+(defmacro geiser-popup--define (base name mode)
+  (let ((get-buff (intern (format "geiser-%s--buffer" base)))
+        (pop-buff (intern (format "geiser-%s--pop-to-buffer" base)))
+        (with-macro (intern (format "geiser-%s--with-buffer" base)))
+        (method (make-symbol "method"))
+        (buffer (make-symbol "buffer")))
+  `(progn
+     (add-to-list 'geiser-popup--registry ,name)
+     (defun ,get-buff ()
+       (or (get-buffer ,name)
+           (with-current-buffer (get-buffer-create ,name)
+             (funcall ',mode)
+             (geiser-popup--setup-view-mode)
+             (current-buffer))))
+     (defun ,pop-buff (&optional ,method)
+       (let ((,buffer (funcall ',get-buff)))
+         (unless (eq ,buffer (current-buffer))
+           (cond ((eq ,method 'buffer) (view-buffer ,buffer))
+                 ((eq ,method 'frame) (view-buffer-other-frame ,buffer))
+                 (t (view-buffer-other-window ,buffer))))))
+     (defmacro ,with-macro (&rest body)
+       (list 'with-current-buffer (list ',get-buff)
+             (cons 'let (cons '((inhibit-read-only t)) body))))
+     (put ',with-macro 'lisp-indent-function 'defun))))
+
+(put 'geiser-popup--define 'lisp-indent-function 1)
+
+
+;;; Reload support:
+
+(defun geiser-popup-unload-function ()
+  (dolist (name geiser-popup--registry)
+    (when (buffer-live-p (get-buffer name))
+      (kill-buffer name))))
+
+
+(provide 'geiser-popup)

elpa/geiser-20171010.1610/geiser-racket.el

@@ -0,0 +1,457 @@
+;; geiser-racket.el -- geiser support for Racket scheme
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Apr 25, 2009 21:13
+
+
+
+(require 'geiser-edit)
+(require 'geiser-doc)
+(require 'geiser-eval)
+(require 'geiser-image)
+(require 'geiser-syntax)
+(require 'geiser-custom)
+(require 'geiser-base)
+(require 'geiser)
+
+(require 'compile)
+
+(eval-when-compile (require 'cl))
+
+
+;;; Customization:
+
+(defgroup geiser-racket nil
+  "Customization for Geiser's Racket flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-racket-binary
+  (cond ((eq system-type 'windows-nt) "Racket.exe")
+        (t "racket"))
+  "Name to use to call the racket executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-gracket-binary
+  (cond ((eq system-type 'windows-nt) "GRacket-text.exe")
+        (t "gracket-text"))
+  "Name to use to call the gracket executable when starting a REPL.
+This executable is used by `run-gracket', and, if
+`geiser-racket-use-gracket-p' is set to t, by `run-racket'."
+  :type '(choice string (repeat string))
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-collects nil
+  "A list of paths to be added to racket's collection directories."
+  :type '(repeat file)
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-init-file "~/.racket-geiser"
+  "Initialization file with user code for the racket REPL."
+  :type 'string
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-use-gracket-p nil
+  "Whether to use the gracket binary to start Racket REPLs."
+  :type 'boolean
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-extra-keywords
+    '("provide" "require" "unless" "when" "with-handlers")
+  "Extra keywords highlighted in Racket buffers."
+  :type '(repeat string)
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-case-sensitive-p t
+  "Non-nil means keyword highlighting is case-sensitive."
+  :type 'boolean
+  :group 'geiser-racket)
+
+
+;;; REPL support:
+
+(defsubst geiser-racket--real-binary ()
+  (if geiser-racket-use-gracket-p
+      geiser-racket-gracket-binary
+    geiser-racket-binary))
+
+(defun geiser-racket--binary ()
+  (let ((binary (geiser-racket--real-binary)))
+    (if (listp binary) (car binary) binary)))
+
+(defun geiser-racket--parameters ()
+  "Return a list with all parameters needed to start racket.
+This function uses `geiser-racket-init-file' if it exists."
+  (let ((init-file (and (stringp geiser-racket-init-file)
+                        (expand-file-name geiser-racket-init-file)))
+        (binary (geiser-racket--real-binary))
+        (rackdir (expand-file-name "racket/" geiser-scheme-dir)))
+    `("-i" "-q" "-S" ,rackdir
+      ,@(apply 'append (mapcar (lambda (p) (list "-S" p))
+                               geiser-racket-collects))
+      ,@(and (listp binary) (cdr binary))
+      ,@(and init-file (file-readable-p init-file) (list "-f" init-file))
+      "-f" ,(expand-file-name "geiser/startup.rkt" rackdir))))
+
+(defconst geiser-racket--prompt-regexp "\\(mzscheme\\|racket\\)@[^ ]*> ")
+
+
+;;; Remote REPLs
+
+(defun connect-to-racket ()
+  "Start a Racket REPL connected to a remote process.
+
+The remote process needs to be running a REPL server started
+using start-geiser, a procedure in the geiser/server module."
+  (interactive)
+  (geiser-connect 'racket))
+
+
+
+;;; Evaluation support:
+
+(defconst geiser-racket--module-re
+  "^(module[+*]? +\\([^ ]+\\)\\W+\\([^ ]+\\)?")
+
+(defun geiser-racket--explicit-module ()
+  (save-excursion
+    (geiser-syntax--pop-to-top)
+    (and (looking-at geiser-racket--module-re)
+         (let ((mod (match-string-no-properties 1))
+               (lang (match-string-no-properties 2)))
+           (cons (geiser-syntax--form-from-string mod)
+                 (geiser-syntax--form-from-string lang))))))
+
+(defun geiser-racket--language ()
+  (or (cdr (geiser-racket--explicit-module))
+      (save-excursion
+        (goto-char (point-min))
+        (if (re-search-forward "^#lang +\\([^ ]+\\)" nil t)
+            (geiser-syntax--form-from-string (match-string-no-properties 1))))
+      "#f"))
+
+(defun geiser-racket--implicit-module (&optional pos)
+  (save-excursion
+    (goto-char (point-min))
+    (when (re-search-forward "^#lang " nil t)
+      (if pos (progn (end-of-line) (list (point))) (buffer-file-name)))))
+
+(defun geiser-racket--eval-bounds ()
+  (geiser-racket--implicit-module t))
+
+(defun geiser-racket--find-module ()
+  (let ((bf (geiser-racket--implicit-module))
+        (sub (car (geiser-racket--explicit-module))))
+    (cond ((and (not bf) (not sub)) nil)
+          ((and (not bf) sub) sub)
+          (sub `(submod (file ,bf) ,sub))
+          (t bf))))
+
+(defun geiser-racket--enter-command (module)
+  (when (or (stringp module) (listp module))
+    (cond ((zerop (length module)) ",enter #f")
+          ((or (listp module)
+               (file-name-absolute-p module)) (format ",enter %S" module))
+          (t (format ",enter %s" module)))))
+
+(defun geiser-racket--geiser-procedure (proc &rest args)
+  (case proc
+    ((eval compile)
+     (format ",geiser-eval %s %s %s"
+             (or (car args) "#f")
+             (geiser-racket--language)
+             (mapconcat 'identity (cdr args) " ")))
+    ((load-file compile-file)
+     (format ",geiser-load %S" (geiser-racket--find-module)))
+    ((no-values) ",geiser-no-values")
+    (t (format ",apply geiser:%s (%s)" proc (mapconcat 'identity args " ")))))
+
+(defun geiser-racket--get-module (&optional module)
+  (cond ((null module) (or (geiser-racket--find-module) :f))
+        ((symbolp module) module)
+        ((and (stringp module) (file-name-absolute-p module)) module)
+        ((stringp module) (make-symbol module))
+        (t nil)))
+
+(defun geiser-racket--symbol-begin (module)
+  (save-excursion (skip-syntax-backward "^'-()>") (point)))
+
+(defun geiser-racket--import-command (module)
+  (and (stringp module)
+       (not (zerop (length module)))
+       (format "(require %s)" module)))
+
+(defun geiser-racket--exit-command ()
+  (comint-send-eof)
+  (get-buffer-process (current-buffer)))
+
+(defconst geiser-racket--binding-forms
+  '("for" "for/list" "for/hash" "for/hasheq" "for/and" "for/or"
+    "for/lists" "for/first" "for/last" "for/fold"
+    "for:" "for/list:" "for/hash:" "for/hasheq:" "for/and:" "for/or:"
+    "for/lists:" "for/first:" "for/last:" "for/fold:"
+    "define-syntax-rule"))
+
+(defconst geiser-racket--binding-forms*
+  '("for*" "for*/list" "for*/lists" "for*/hash" "for*/hasheq" "for*/and"
+    "for*/or" "for*/first" "for*/last" "for*/fold"
+    "for*:" "for*/list:" "for*/lists:" "for*/hash:" "for*/hasheq:" "for*/and:"
+    "for*/or:" "for*/first:" "for*/last:" "for*/fold:"))
+
+;;; External help
+
+(defsubst geiser-racket--get-help (symbol module)
+  (geiser-eval--send/wait `(:scm ,(format ",help %s %s" symbol module))))
+
+(defun geiser-racket--external-help (id module)
+  (message "Looking up manual for '%s'..." id)
+  (let* ((ret (geiser-racket--get-help id (format "%S" module)))
+         (out (geiser-eval--retort-output ret))
+         (ret (if (and out (string-match " but provided by:\n +\\(.+\\)\n" out))
+                  (geiser-racket--get-help id (match-string 1 out))
+                ret)))
+    (unless (string-match "^Sending to web browser.+"
+                          (geiser-eval--retort-output ret))
+      (minibuffer-message "%s not found" (current-message)))
+    t))
+
+
+;;; Error display
+
+(defconst geiser-racket--file-rxs
+  '(nil
+    "path:\"?\\([^>\"\n]+\\)\"?>"
+    "module: \"\\([^>\"\n]+\\)\""))
+
+(defconst geiser-racket--geiser-file-rx
+  (format "^ *%s/?racket/geiser" (regexp-quote geiser-scheme-dir)))
+
+(defun geiser-racket--purge-trace ()
+  (save-excursion
+    (while (re-search-forward geiser-racket--geiser-file-rx nil t)
+      (kill-whole-line))))
+
+(defun geiser-racket--display-error (module key msg)
+  (when key
+    (insert "Error: ")
+    (geiser-doc--insert-button key nil 'racket)
+    (newline 2))
+  (when msg
+    (let ((p (point)))
+      (insert msg)
+      (let ((end (point)))
+        (goto-char p)
+        (when key (geiser-racket--purge-trace))
+        (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs)
+        (goto-char end)
+        (newline))))
+  (if (and msg (string-match "\\(.+\\)$" msg)) (match-string 1 msg) key))
+
+
+;;; Trying to ascertain whether a buffer is racket code:
+
+(defun geiser-racket--guess ()
+  (or (save-excursion
+        (goto-char (point-min))
+        (re-search-forward "#lang " nil t))
+      (geiser-racket--explicit-module)))
+
+
+;;; Keywords and syntax
+
+(defvar geiser-racket-font-lock-forms
+  '(("^#lang\\>" . 0)
+    ("\\[\\(else\\)\\>" . 1)
+    ("(\\(define/match\\)\\W+[[(]?\\(\\w+\\)+\\b"
+     (1 font-lock-keyword-face)
+     (2 font-lock-function-name-face))))
+
+(defun geiser-racket--keywords ()
+  (append geiser-racket-font-lock-forms
+          (geiser-syntax--simple-keywords geiser-racket-extra-keywords)))
+
+(geiser-syntax--scheme-indent
+ (begin0 1)
+ (case-lambda: 0)
+ (class* defun)
+ (compound-unit/sig 0)
+ (define: defun)
+ (for 1)
+ (for* 1)
+ (for*/and 1)
+ (for*/first 1)
+ (for*/fold 2)
+ (for*/hash 1)
+ (for*/hasheq 1)
+ (for*/hasheqv 1)
+ (for*/last 1)
+ (for*/list 1)
+ (for*/lists 2)
+ (for*/or 1)
+ (for*/product 1)
+ (for*/set 1)
+ (for*/seteq 1)
+ (for*/seteqv 1)
+ (for*/sum 1)
+ (for*/vector 1)
+ (for/and 1)
+ (for/first 1)
+ (for/fold 2)
+ (for/hash 1)
+ (for/hasheq 1)
+ (for/hasheqv 1)
+ (for/last 1)
+ (for/list 1)
+ (for/lists 2)
+ (for/or 1)
+ (for/product 1)
+ (for/set 1)
+ (for/seteq 1)
+ (for/seteqv 1)
+ (for/sum 1)
+ (for/vector 1)
+ (instantiate 2)
+ (interface 1)
+ (lambda/kw 1)
+ (lambda: 1)
+ (let*-values: 1)
+ (let+ 1)
+ (let-values: 1)
+ (let/cc: 1)
+ (let: 1)
+ (letrec-values: 1)
+ (letrec: 1)
+ (local 1)
+ (match-let 1)
+ (match-let-values 1)
+ (match/values 1)
+ (mixin 2)
+ (module defun)
+ (module+ defun)
+ (module* defun)
+ (parameterize-break 1)
+ (quasisyntax/loc 1)
+ (send* 1)
+ (splicing-let 1)
+ (splicing-let-syntax 1)
+ (splicing-let-syntaxes 1)
+ (splicing-let-values 1)
+ (splicing-letrec 1)
+ (splicing-letrec-syntax 1)
+ (splicing-letrec-syntaxes 1)
+ (splicing-letrec-syntaxes+values 1)
+ (splicing-letrec-values 1)
+ (splicing-local 1)
+ (shared 1)
+ (struct 1)
+ (syntax-id-rules defun)
+ (syntax/loc 1)
+ (type-case defun)
+ (unit defun)
+ (unit/sig 2)
+ (with-handlers 1)
+ (with-handlers: 1))
+
+
+;;; REPL Startup
+
+(defvar geiser-racket-minimum-version "5.3")
+
+(defun geiser-racket--version (binary)
+  (car (process-lines binary "-e" "(display (version))")))
+
+(defvar geiser-racket--image-cache-dir nil)
+
+(defun geiser-racket--startup (remote)
+  (set (make-local-variable 'compilation-error-regexp-alist)
+       `(("^ *\\([^:(\t\n]+\\):\\([0-9]+\\):\\([0-9]+\\):" 1 2 3)))
+  (compilation-setup t)
+  (if geiser-image-cache-dir
+      (geiser-eval--send/wait
+       `(:eval (image-cache ,geiser-image-cache-dir) geiser/user))
+    (setq geiser-racket--image-cache-dir
+          (geiser-eval--send/result '(:eval (image-cache) geiser/user)))))
+
+(defun geiser-racket--image-cache-dir ()
+  (or geiser-image-cache-dir geiser-racket--image-cache-dir))
+
+
+;;; Additional commands
+
+(defvar geiser-racket--submodule-history ())
+
+(defun geiser-racket--submodule-form (name)
+  (format "module[+*]? %s"
+          (cond ((eq 1 name) "")
+                ((numberp name)
+                 (read-string "Submodule name: " nil
+                              'geiser-racket--submodule-history))
+                ((stringp name) name)
+                (t ""))))
+
+(defun geiser-racket-toggle-submodules (&optional name)
+  "Toggle visibility of submodule forms.
+
+Use a prefix to be asked for a submodule name."
+  (interactive "p")
+  (geiser-edit--toggle-visibility (geiser-racket--submodule-form name)))
+
+(defun geiser-racket-show-submodules (&optional name)
+  "Unconditionally shows all submodule forms.
+
+Use a prefix to be asked for a submodule name."
+  (interactive "p")
+  (cond ((eq 1 name) (geiser-edit--show-all))
+        (t (geiser-edit--show (geiser-racket--submodule-form name)))))
+
+(defun geiser-racket-hide-submodules (&optional name)
+  "Unconditionally hides all visible submodules.
+
+Use a prefix to be asked for a submodule name."
+  (interactive "p")
+  (geiser-edit--hide (geiser-racket--submodule-form name)))
+
+
+;;; Implementation definition:
+
+(define-geiser-implementation racket
+  (unsupported-procedures '(callers callees generic-methods))
+  (binary geiser-racket--binary)
+  (minimum-version geiser-racket-minimum-version)
+  (version-command geiser-racket--version)
+  (arglist geiser-racket--parameters)
+  (repl-startup geiser-racket--startup)
+  (prompt-regexp geiser-racket--prompt-regexp)
+  (marshall-procedure geiser-racket--geiser-procedure)
+  (find-module geiser-racket--get-module)
+  (enter-command geiser-racket--enter-command)
+  (import-command geiser-racket--import-command)
+  (exit-command geiser-racket--exit-command)
+  (find-symbol-begin geiser-racket--symbol-begin)
+  (eval-bounds geiser-racket--eval-bounds)
+  (display-error geiser-racket--display-error)
+  (external-help geiser-racket--external-help)
+  (check-buffer geiser-racket--guess)
+  (keywords geiser-racket--keywords)
+  (image-cache-dir geiser-racket--image-cache-dir)
+  (case-sensitive geiser-racket-case-sensitive-p)
+  (binding-forms geiser-racket--binding-forms)
+  (binding-forms* geiser-racket--binding-forms*))
+
+(geiser-impl--add-to-alist 'regexp "\\.ss$" 'racket t)
+(geiser-impl--add-to-alist 'regexp "\\.rkt$" 'racket t)
+
+(defun run-gracket ()
+  "Start the Racket REPL using gracket instead of plain racket."
+  (interactive)
+  (let ((geiser-racket-use-gracket-p t))
+    (run-racket)))
+
+
+(provide 'geiser-racket)

elpa/geiser-20171010.1610/geiser-reload.el

@@ -0,0 +1,87 @@
+;; geiser-reload.el -- unload/load geiser packages
+
+;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Aug 22, 2009 23:04
+
+
+
+(require 'geiser-repl)
+(require 'geiser-mode)
+(require 'geiser-custom)
+(require 'geiser-base)
+(require 'geiser)
+(require 'geiser-load nil t)
+(require 'geiser-install nil t)
+
+
+;;; Reload:
+
+(defmacro geiser--features-list ()
+  (quote '(
+           geiser-mode
+           geiser-repl
+           geiser-doc
+           geiser-xref
+           geiser-compile
+           geiser-debug
+           geiser-company
+           geiser-edit
+           geiser-completion
+           geiser-autodoc
+           geiser-eval
+           geiser-connection
+           geiser-syntax
+           geiser-menu
+           geiser-inf
+           geiser-impl
+           geiser-image
+           geiser-custom
+           geiser-log
+           geiser-popup
+           geiser-base
+           geiser-version
+           geiser-install
+           geiser
+           )))
+
+(defun geiser-unload ()
+  "Unload all Geiser modules."
+  (interactive)
+  (let ((fs (geiser--features-list)))
+    (unload-feature 'geiser-reload t)
+    (dolist (f fs)
+      (when (featurep f) (unload-feature f t)))
+    (remove-hook 'scheme-mode-hook 'geiser-mode--maybe-activate)))
+
+(defun geiser-reload (&optional arg)
+  "Reload Geiser.
+With prefix arg, prompts for the DIRECTORY from which Geiser should be
+loaded again."
+  (interactive "P")
+  (let* ((old-dir geiser-elisp-dir)
+         (dir (or (and arg (read-directory-name "New Geiser elisp dir: "
+                                                old-dir old-dir t old-dir))
+                  old-dir)))
+    (unless (or (file-exists-p (expand-file-name "geiser-reload.el" dir))
+                (file-exists-p (expand-file-name "geiser-reload.elc" dir)))
+      (error "%s does not contain Geiser!" dir))
+    (let ((memo (geiser-custom--memoized-state))
+          (repls (geiser-repl--repl-list))
+          (buffers (geiser-mode--buffers)))
+      (geiser-unload)
+      (setq load-path (remove old-dir load-path))
+      (add-to-list 'load-path dir)
+      (mapc (lambda (x) (set (car x) (cdr x))) memo)
+      (require 'geiser-reload)
+      (geiser-repl--restore repls)
+      (geiser-mode--restore buffers)
+      (message "Geiser reloaded!"))))
+
+
+(provide 'geiser-reload)

elpa/geiser-20171010.1610/geiser-repl.el

@@ -0,0 +1,901 @@
+;;; geiser-repl.el --- Geiser's REPL
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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-company)
+(require 'geiser-doc)
+(require 'geiser-autodoc)
+(require 'geiser-edit)
+(require 'geiser-completion)
+(require 'geiser-syntax)
+(require 'geiser-impl)
+(require 'geiser-eval)
+(require 'geiser-connection)
+(require 'geiser-menu)
+(require 'geiser-image)
+(require 'geiser-custom)
+(require 'geiser-base)
+
+(require 'comint)
+(require 'compile)
+(require 'scheme)
+
+
+;;; Customization:
+
+(defgroup geiser-repl nil
+  "Interacting with the Geiser REPL."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-repl-buffer-name-function
+    'geiser-repl-buffer-name
+  "Function used to define the name of a REPL buffer.
+The function is called with a single argument - an implementation
+symbol (e.g., `guile', `chicken', etc.)."
+  :type '(choice (function-item geiser-repl-buffer-name)
+                 (function :tag "Other function"))
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-use-other-window t
+  "Whether to Use a window other than the current buffer's when
+switching to the Geiser REPL buffer."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-window-allow-split t
+  "Whether to allow window splitting when switching to the Geiser
+REPL buffer."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-history-filename
+    (expand-file-name "~/.geiser_history")
+  "File where REPL input history is saved, so that it persists between sessions.
+
+This is actually the base name: the concrete Scheme
+implementation name gets appended to it."
+  :type 'file
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-history-size comint-input-ring-size
+  "Maximum size of the saved REPL input history."
+  :type 'integer
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-history-no-dups-p t
+  "Whether to skip duplicates when recording history."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-save-debugging-history-p nil
+  "Whether to skip debugging input in REPL history.
+
+By default, REPL interactions while scheme is in the debugger are
+not added to the REPL command history.  Set this variable to t to
+change that."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-autodoc-p t
+  "Whether to enable `geiser-autodoc-mode' in the REPL by default."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-company-p t
+  "Whether to use company-mode for completion, if available."
+  :group 'geiser-mode
+  :type 'boolean)
+
+(geiser-custom--defcustom geiser-repl-read-only-prompt-p t
+  "Whether the REPL's prompt should be read-only."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-auto-indent-p t
+  "Whether newlines for incomplete sexps are autoindented."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-forget-old-errors-p t
+  "Whether to forget old errors upon entering a new expression.
+
+When on (the default), every time a new expression is entered in
+the REPL old error messages are flushed, and using \\[next-error]
+afterwards will jump only to error locations produced by the new
+expression, if any."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-skip-version-check-p nil
+  "Whether to skip version checks for the Scheme executable.
+
+When set, Geiser won't check the version of the Scheme
+interpreter when starting a REPL, saving a few tenths of a
+second.
+"
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-query-on-exit-p nil
+  "Whether to prompt for confirmation on \\[geiser-repl-exit]."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-query-on-kill-p t
+  "Whether to prompt for confirmation when killing a REPL buffer with
+a life process."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-default-host "localhost"
+  "Default host when connecting to remote REPLs."
+  :type 'string
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-default-port 37146
+  "Default port for connecting to remote REPLs."
+  :type 'integer
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-startup-time 10000
+  "Time, in milliseconds, to wait for Racket to startup.
+If you have a slow system, try to increase this time."
+  :type 'integer
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-inline-images-p t
+  "Whether to display inline images in the REPL."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defcustom geiser-repl-auto-display-images-p t
+  "Whether to automatically invoke the external viewer to display
+images popping up in the REPL.
+
+See also `geiser-debug-auto-display-images-p'."
+  :type 'boolean
+  :group 'geiser-repl)
+
+(geiser-custom--defface repl-input
+  'comint-highlight-input geiser-repl "evaluated input highlighting")
+
+(geiser-custom--defface repl-prompt
+  'comint-highlight-prompt geiser-repl "REPL prompt")
+
+
+
+;;; Implementation-dependent parameters
+
+(geiser-impl--define-caller geiser-repl--binary binary ()
+  "A variable or function returning the path to the scheme binary
+for this implementation.")
+
+(geiser-impl--define-caller geiser-repl--arglist arglist ()
+  "A function taking no arguments and returning a list of
+arguments to be used when invoking the scheme binary.")
+
+(geiser-impl--define-caller geiser-repl--prompt-regexp prompt-regexp ()
+  "A variable (or thunk returning a value) giving the regular
+expression for this implementation's geiser scheme prompt.")
+
+(geiser-impl--define-caller
+    geiser-repl--debugger-prompt-regexp debugger-prompt-regexp ()
+  "A variable (or thunk returning a value) giving the regular
+expression for this implementation's debugging prompt.")
+
+(geiser-impl--define-caller geiser-repl--startup repl-startup (remote)
+  "Function taking no parameters that is called after the REPL
+has been initialised. All Geiser functionality is available to
+you at that point.")
+
+(geiser-impl--define-caller geiser-repl--enter-cmd enter-command (module)
+  "Function taking a module designator and returning a REPL enter
+module command as a string")
+
+(geiser-impl--define-caller geiser-repl--import-cmd import-command (module)
+  "Function taking a module designator and returning a REPL import
+module command as a string")
+
+(geiser-impl--define-caller geiser-repl--exit-cmd exit-command ()
+  "Function returning the REPL exit command as a string")
+
+(geiser-impl--define-caller geiser-repl--version version-command (binary)
+  "Function returning the version of the corresponding scheme process,
+   given its full path.")
+
+(geiser-impl--define-caller geiser-repl--min-version minimum-version ()
+  "A variable providing the minimum required scheme version, as a string.")
+
+
+;;; Geiser REPL buffers and processes:
+
+(defvar geiser-repl--repls nil)
+(defvar geiser-repl--closed-repls nil)
+
+(make-variable-buffer-local
+ (defvar geiser-repl--repl nil))
+
+(defsubst geiser-repl--set-this-buffer-repl (r)
+  (setq geiser-repl--repl r))
+
+(defun geiser-repl--live-p ()
+  (and geiser-repl--repl
+       (get-buffer-process geiser-repl--repl)))
+
+(defun geiser-repl--repl/impl (impl &optional repls)
+  (catch 'repl
+    (dolist (repl (or repls geiser-repl--repls))
+      (when (buffer-live-p repl)
+        (with-current-buffer repl
+          (when (eq geiser-impl--implementation impl)
+            (throw 'repl repl)))))))
+
+(defun geiser-repl--set-up-repl (impl)
+  (or (and (not impl) geiser-repl--repl)
+      (setq geiser-repl--repl
+            (let ((impl (or impl
+                            geiser-impl--implementation
+                            (geiser-impl--guess))))
+              (when impl (geiser-repl--repl/impl impl))))))
+
+(defun geiser-repl--active-impls ()
+  (let ((act))
+    (dolist (repl geiser-repl--repls act)
+      (with-current-buffer repl
+        (add-to-list 'act geiser-impl--implementation)))))
+
+(defsubst geiser-repl--repl-name (impl)
+  (format "%s REPL" (geiser-impl--impl-str impl)))
+
+(defsubst geiser-repl--buffer-name (impl)
+  (funcall geiser-repl-buffer-name-function impl))
+
+(defun geiser-repl-buffer-name (impl)
+  "Return default name of the REPL buffer for implementation IMPL."
+  (format "* %s *" (geiser-repl--repl-name impl)))
+
+(defun geiser-repl--switch-to-buffer (buffer)
+  (unless (eq buffer (current-buffer))
+    (let ((pop-up-windows geiser-repl-window-allow-split))
+      (if geiser-repl-use-other-window
+          (switch-to-buffer-other-window buffer)
+        (switch-to-buffer buffer)))))
+
+(defun geiser-repl--to-repl-buffer (impl)
+  (unless (and (eq major-mode 'geiser-repl-mode)
+               (eq geiser-impl--implementation impl)
+               (not (get-buffer-process (current-buffer))))
+    (let* ((old (geiser-repl--repl/impl impl geiser-repl--closed-repls))
+           (old (and (buffer-live-p old)
+                     (not (get-buffer-process old))
+                     old)))
+      (geiser-repl--switch-to-buffer
+       (or old (generate-new-buffer (geiser-repl--buffer-name impl))))
+      (unless old
+        (geiser-repl-mode)
+        (geiser-impl--set-buffer-implementation impl)
+        (geiser-syntax--add-kws t)))))
+
+(defun geiser-repl--read-impl (prompt &optional active)
+  (geiser-impl--read-impl prompt (and active (geiser-repl--active-impls))))
+
+(defsubst geiser-repl--only-impl-p ()
+  (and (null (cdr geiser-active-implementations))
+       (car geiser-active-implementations)))
+
+(defun geiser-repl--get-impl (prompt)
+  (or (geiser-repl--only-impl-p)
+      (and (eq major-mode 'geiser-repl-mode) geiser-impl--implementation)
+      (geiser-repl--read-impl prompt)))
+
+
+;;; Prompt &co.
+
+(defun geiser-repl--last-prompt-end ()
+  (cond ((and (boundp 'comint-last-prompt) (markerp (cdr comint-last-prompt)))
+         (marker-position (cdr comint-last-prompt)))
+        ((and (boundp 'comint-last-prompt-overlay) comint-last-prompt-overlay)
+         (overlay-end comint-last-prompt-overlay))
+        (t (save-excursion
+             (geiser-repl--bol)
+             (min (+ 1 (point)) (point-max))))))
+
+(defun geiser-repl--last-prompt-start ()
+  (cond ((and (boundp 'comint-last-prompt) (markerp (car comint-last-prompt)))
+         (marker-position (car comint-last-prompt)))
+        ((and (boundp 'comint-last-prompt-overlay) comint-last-prompt-overlay)
+         (overlay-start comint-last-prompt-overlay))
+        (t (save-excursion (geiser-repl--bol) (point)))))
+
+
+;;; REPL connections
+
+(make-variable-buffer-local
+ (defvar geiser-repl--address nil))
+
+(make-variable-buffer-local
+ (defvar geiser-repl--connection nil))
+
+(defun geiser-repl--local-p ()
+  "Return non-nil, if current REPL is local (connected to socket)."
+  (stringp geiser-repl--address))
+
+(defun geiser-repl--remote-p ()
+  "Return non-nil, if current REPL is remote (connected to host:port)."
+  (consp geiser-repl--address))
+
+(defsubst geiser-repl--host () (car geiser-repl--address))
+(defsubst geiser-repl--port () (cdr geiser-repl--address))
+
+(defun geiser-repl--read-address (&optional host port)
+  (let ((defhost (or (geiser-repl--host) geiser-repl-default-host))
+        (defport (or (geiser-repl--port) geiser-repl-default-port)))
+    (cons (or host
+              (read-string (format "Host (default %s): " defhost)
+                           nil nil defhost))
+          (or port (read-number "Port: " defport)))))
+
+(defun geiser-repl--autodoc-mode (n)
+  (when (or geiser-repl-autodoc-p (< n 0))
+    (geiser--save-msg (geiser-autodoc-mode n))))
+
+(defun geiser-repl--save-remote-data (address)
+  (setq geiser-repl--address address)
+  (setq header-line-format
+	(cond ((consp address)
+	       (format "Host: %s   Port: %s"
+		       (geiser-repl--host)
+		       (geiser-repl--port)))
+	      ((stringp address)
+	       (format "Socket: %s" address))
+	      (t nil))))
+
+(defun geiser-repl--output-filter (txt)
+  (geiser-con--connection-update-debugging geiser-repl--connection txt)
+  (geiser-image--replace-images geiser-repl-inline-images-p
+                                geiser-repl-auto-display-images-p)
+  (when (string-match-p (geiser-con--connection-prompt geiser-repl--connection)
+                        txt)
+    (geiser-autodoc--disinhibit-autodoc)))
+
+(defun geiser-repl--check-version (impl)
+  (when (not geiser-repl-skip-version-check-p)
+    (let ((v (geiser-repl--version impl (geiser-repl--binary impl)))
+          (r (geiser-repl--min-version impl)))
+      (when (and v r (geiser--version< v r))
+        (error "Geiser requires %s version %s but detected %s" impl r v)))))
+
+(defun geiser-repl--start-repl (impl address)
+  (message "Starting Geiser REPL for %s ..." impl)
+  (when (not address) (geiser-repl--check-version impl))
+  (geiser-repl--to-repl-buffer impl)
+  (sit-for 0)
+  (goto-char (point-max))
+  (geiser-repl--autodoc-mode -1)
+  (let* ((prompt-rx (geiser-repl--prompt-regexp impl))
+         (deb-prompt-rx (geiser-repl--debugger-prompt-regexp impl))
+         (prompt (geiser-con--combined-prompt prompt-rx deb-prompt-rx)))
+    (unless prompt-rx
+      (error "Sorry, I don't know how to start a REPL for %s" impl))
+    (geiser-repl--save-remote-data address)
+    (geiser-repl--start-scheme impl address prompt)
+    (geiser-repl--quit-setup)
+    (geiser-repl--history-setup)
+    (add-to-list 'geiser-repl--repls (current-buffer))
+    (geiser-repl--set-this-buffer-repl (current-buffer))
+    (setq geiser-repl--connection
+          (geiser-con--make-connection (get-buffer-process (current-buffer))
+                                       prompt-rx
+                                       deb-prompt-rx))
+    (geiser-repl--startup impl address)
+    (geiser-repl--autodoc-mode 1)
+    (geiser-company--setup geiser-repl-company-p)
+    (add-hook 'comint-output-filter-functions
+              'geiser-repl--output-filter
+              nil
+              t)
+    (set-process-query-on-exit-flag (get-buffer-process (current-buffer))
+                                    geiser-repl-query-on-kill-p)
+    (message "%s up and running!" (geiser-repl--repl-name impl))))
+
+(defun geiser-repl--start-scheme (impl address prompt)
+  (setq comint-prompt-regexp prompt)
+  (let* ((name (geiser-repl--repl-name impl))
+         (buff (current-buffer))
+         (args (cond ((consp address) (list address))
+		     ((stringp address) '(()))
+		     (t `(,(geiser-repl--binary impl)
+			  nil
+			  ,@(geiser-repl--arglist impl))))))
+    (condition-case err
+        (if (and address (stringp address))
+            ;; Connect over a Unix-domain socket.
+            (let ((proc (make-network-process :name (buffer-name buff)
+                                              :buffer buff
+                                              :family 'local
+                                              :remote address)))
+              ;; brittleness warning: this is stuff
+              ;; make-comint-in-buffer sets up, via comint-exec, when
+              ;; it creates its own process, something we're doing
+              ;; here by ourselves.
+              (set-process-filter proc 'comint-output-filter)
+              (goto-char (point-max))
+              (set-marker (process-mark proc) (point)))
+          (apply 'make-comint-in-buffer `(,name ,buff ,@args)))
+      (error (insert "Unable to start REPL:\n"
+                     (error-message-string err)
+                     "\n")
+             (error "Couldn't start Geiser: %s" err)))
+    (geiser-repl--wait-for-prompt geiser-repl-startup-time)))
+
+(defun geiser-repl--wait-for-prompt (timeout)
+  (let ((p (point)) (seen) (buffer (current-buffer)))
+    (while (and (not seen)
+                (> timeout 0)
+                (get-buffer-process buffer))
+      (sleep-for 0.1)
+      (setq timeout (- timeout 100))
+      (goto-char p)
+      (setq seen (re-search-forward comint-prompt-regexp nil t)))
+    (goto-char (point-max))
+    (unless seen (error "%s" "No prompt found!"))))
+
+(defun geiser-repl--is-debugging ()
+  (let ((dp (geiser-con--connection-debug-prompt geiser-repl--connection)))
+    (and dp
+         (save-excursion
+           (goto-char (geiser-repl--last-prompt-start))
+           (re-search-forward dp (geiser-repl--last-prompt-end) t)))))
+
+(defun geiser-repl--connection* ()
+  (let ((buffer (geiser-repl--set-up-repl geiser-impl--implementation)))
+   (and (buffer-live-p buffer)
+        (get-buffer-process buffer)
+        (with-current-buffer buffer geiser-repl--connection))))
+
+(defun geiser-repl--connection ()
+  (or (geiser-repl--connection*)
+      (error "No Geiser REPL for this buffer (try M-x run-geiser)")))
+
+(setq geiser-eval--default-connection-function 'geiser-repl--connection)
+
+(defun geiser-repl--prepare-send ()
+  (geiser-image--clean-cache)
+  (geiser-autodoc--inhibit-autodoc)
+  (geiser-con--connection-deactivate geiser-repl--connection))
+
+(defun geiser-repl--send (cmd &optional save-history)
+  "Send CMD input string to the current REPL buffer.
+If SAVE-HISTORY is non-nil, save CMD in the REPL history."
+  (when (and cmd (eq major-mode 'geiser-repl-mode))
+    (geiser-repl--prepare-send)
+    (goto-char (point-max))
+    (comint-kill-input)
+    (insert cmd)
+    (let ((comint-input-filter (if save-history
+                                   comint-input-filter
+                                 'ignore)))
+      (comint-send-input nil t))))
+
+(defun geiser-repl-interrupt ()
+  (interactive)
+  (when (get-buffer-process (current-buffer))
+    (interrupt-process nil comint-ptyp)))
+
+
+;;; REPL history
+
+(defconst geiser-repl--history-separator "\n}{\n")
+
+(defsubst geiser-repl--history-file ()
+  (format "%s.%s" geiser-repl-history-filename geiser-impl--implementation))
+
+(defun geiser-repl--read-input-ring ()
+  (let ((comint-input-ring-file-name (geiser-repl--history-file))
+        (comint-input-ring-separator geiser-repl--history-separator)
+        (buffer-file-coding-system 'utf-8))
+    (comint-read-input-ring t)))
+
+(defun geiser-repl--write-input-ring ()
+  (let ((comint-input-ring-file-name (geiser-repl--history-file))
+        (comint-input-ring-separator geiser-repl--history-separator)
+        (buffer-file-coding-system 'utf-8))
+    (comint-write-input-ring)))
+
+(defun geiser-repl--history-setup ()
+  (set (make-local-variable 'comint-input-ring-size) geiser-repl-history-size)
+  (set (make-local-variable 'comint-input-filter) 'geiser-repl--input-filter)
+  (geiser-repl--read-input-ring))
+
+
+;;; Cleaning up
+
+(defun geiser-repl--on-quit ()
+  (geiser-repl--write-input-ring)
+  (let ((cb (current-buffer))
+        (impl geiser-impl--implementation)
+        (comint-prompt-read-only nil))
+    (geiser-con--connection-deactivate geiser-repl--connection t)
+    (geiser-con--connection-close geiser-repl--connection)
+    (setq geiser-repl--repls (remove cb geiser-repl--repls))
+    (dolist (buffer (buffer-list))
+      (when (buffer-live-p buffer)
+        (with-current-buffer buffer
+          (when (and (eq geiser-impl--implementation impl)
+                     (equal cb geiser-repl--repl))
+            (geiser-repl--set-up-repl geiser-impl--implementation)))))))
+
+(defun geiser-repl--sentinel (proc event)
+  (let ((pb (process-buffer proc)))
+    (when (buffer-live-p pb)
+      (with-current-buffer pb
+        (let ((comint-prompt-read-only nil)
+              (comint-input-ring-file-name (geiser-repl--history-file))
+              (comint-input-ring-separator geiser-repl--history-separator))
+          (geiser-repl--on-quit)
+          (push pb geiser-repl--closed-repls)
+          (goto-char (point-max))
+          (comint-kill-region comint-last-input-start (point))
+          (insert "\nIt's been nice interacting with you!\n")
+          (insert "Press C-c C-z to bring me back.\n" ))))))
+
+(defun geiser-repl--on-kill ()
+  (geiser-repl--on-quit)
+  (setq geiser-repl--closed-repls
+        (remove (current-buffer) geiser-repl--closed-repls)))
+
+(defun geiser-repl--input-filter (str)
+  (not (or (and (not geiser-repl-save-debugging-history-p)
+                (geiser-repl--is-debugging))
+           (string-match "^\\s *$" str)
+           (string-match "^,quit *$" str))))
+
+(defun geiser-repl--old-input ()
+  (save-excursion
+    (let ((end (point)))
+      (backward-sexp)
+      (buffer-substring (point) end))))
+
+(defun geiser-repl--quit-setup ()
+  (add-hook 'kill-buffer-hook 'geiser-repl--on-kill nil t)
+  (set-process-sentinel (get-buffer-process (current-buffer))
+                        'geiser-repl--sentinel))
+
+
+;;; geiser-repl mode:
+
+(defun geiser-repl--bol ()
+  (interactive)
+  (when (= (point) (comint-bol)) (beginning-of-line)))
+
+(defun geiser-repl--beginning-of-defun ()
+  (save-restriction
+    (narrow-to-region (geiser-repl--last-prompt-end) (point))
+    (let ((beginning-of-defun-function nil))
+      (beginning-of-defun))))
+
+(defun geiser-repl--module-function (&optional module)
+  (if (and module geiser-eval--get-impl-module)
+      (funcall geiser-eval--get-impl-module module)
+      :f))
+
+(defun geiser-repl--doc-module ()
+  (interactive)
+  (let ((geiser-eval--get-module-function
+         (geiser-impl--method 'find-module geiser-impl--implementation)))
+    (geiser-doc-module)))
+
+(defun geiser-repl--newline-and-indent ()
+  (interactive)
+  (save-restriction
+    (narrow-to-region comint-last-input-start (point-max))
+    (insert "\n")
+    (lisp-indent-line)))
+
+(defun geiser-repl--nesting-level ()
+  (save-restriction
+    (narrow-to-region (geiser-repl--last-prompt-end) (point-max))
+    (geiser-syntax--nesting-level)))
+
+(defun geiser-repl--is-input ()
+  (not (eq (field-at-pos (point)) 'output)))
+
+(defun geiser-repl--grab-input ()
+  (let ((pos (comint-bol)))
+    (goto-char (point-max))
+    (insert (field-string-no-properties pos))))
+
+(defun geiser-repl--send-input ()
+  (let* ((proc (get-buffer-process (current-buffer)))
+         (pmark (and proc (process-mark proc)))
+         (intxt (and pmark (buffer-substring pmark (point))))
+	 (eob (point-max)))
+    (when intxt
+      (and geiser-repl-forget-old-errors-p
+           (not (geiser-repl--is-debugging))
+           (compilation-forget-errors))
+      (geiser-repl--prepare-send)
+      (comint-send-input)
+      (when (string-match "^\\s-*$" intxt)
+        (comint-send-string proc (geiser-eval--scheme-str '(:ge no-values)))
+        (comint-send-string proc "\n")))))
+
+(defun geiser-repl--maybe-send ()
+  (interactive)
+  (let ((p (point)))
+    (cond ((< p (geiser-repl--last-prompt-start))
+	   (if (geiser-repl--is-input)
+	       (geiser-repl--grab-input)
+	     (ignore-errors (compile-goto-error))))
+          ((let ((inhibit-field-text-motion t))
+             (end-of-line)
+             (<= (geiser-repl--nesting-level) 0))
+           (geiser-repl--send-input))
+          (t (goto-char p)
+             (if geiser-repl-auto-indent-p
+                 (geiser-repl--newline-and-indent)
+               (insert "\n"))))))
+
+(defun geiser-repl-tab-dwim (n)
+  "If we're after the last prompt, complete symbol or indent (if
+there's no symbol at point). Otherwise, go to next error in the REPL
+buffer."
+  (interactive "p")
+  (if (>= (point) (geiser-repl--last-prompt-end))
+      (or (completion-at-point)
+          (lisp-indent-line))
+    (compilation-next-error n)))
+
+(defun geiser-repl--previous-error (n)
+  "Go to previous error in the REPL buffer."
+  (interactive "p")
+  (compilation-next-error (- n)))
+
+(defun geiser-repl-clear-buffer ()
+  "Delete the output generated by the scheme process."
+  (interactive)
+  (let ((inhibit-read-only t))
+    (delete-region (point-min) (geiser-repl--last-prompt-start))
+    (when (< (point) (geiser-repl--last-prompt-end))
+      (goto-char (geiser-repl--last-prompt-end)))
+    (recenter t)))
+
+(define-derived-mode geiser-repl-mode comint-mode "REPL"
+  "Major mode for interacting with an inferior scheme repl process.
+\\{geiser-repl-mode-map}"
+  (scheme-mode-variables)
+  (set (make-local-variable 'face-remapping-alist)
+       '((comint-highlight-prompt geiser-font-lock-repl-prompt)
+         (comint-highlight-input geiser-font-lock-repl-input)))
+  (set (make-local-variable 'mode-line-process) nil)
+  (set (make-local-variable 'comint-use-prompt-regexp) nil)
+  (set (make-local-variable 'comint-prompt-read-only)
+       geiser-repl-read-only-prompt-p)
+  (setq comint-process-echoes nil)
+  (set (make-local-variable 'beginning-of-defun-function)
+       'geiser-repl--beginning-of-defun)
+  (set (make-local-variable 'comint-input-ignoredups)
+       geiser-repl-history-no-dups-p)
+  (setq geiser-eval--get-module-function 'geiser-repl--module-function)
+  (geiser-completion--setup t)
+  (setq geiser-smart-tab-mode-string "")
+  (geiser-smart-tab-mode t)
+  ;; enabling compilation-shell-minor-mode without the annoying highlighter
+  (compilation-setup t))
+
+(define-key geiser-repl-mode-map "\C-d" 'delete-char)
+(define-key geiser-repl-mode-map "\C-m" 'geiser-repl--maybe-send)
+(define-key geiser-repl-mode-map [return] 'geiser-repl--maybe-send)
+(define-key geiser-repl-mode-map "\C-j" 'geiser-repl--newline-and-indent)
+(define-key geiser-repl-mode-map (kbd "TAB") 'geiser-repl-tab-dwim)
+(define-key geiser-repl-mode-map [backtab] 'geiser-repl--previous-error)
+
+(define-key geiser-repl-mode-map "\C-a" 'geiser-repl--bol)
+(define-key geiser-repl-mode-map (kbd "<home>") 'geiser-repl--bol)
+
+(geiser-menu--defmenu repl geiser-repl-mode-map
+  ("Complete symbol" ((kbd "M-TAB"))
+   completion-at-point :enable (geiser--symbol-at-point))
+  ("Complete module name" ((kbd "C-.") (kbd "M-`"))
+   geiser-completion--complete-module :enable (geiser--symbol-at-point))
+  ("Edit symbol" "\M-." geiser-edit-symbol-at-point
+   :enable (geiser--symbol-at-point))
+  --
+  ("Load scheme file..." "\C-c\C-l" geiser-load-file)
+  ("Switch to module..." "\C-c\C-m" switch-to-geiser-module)
+  ("Import module..." "\C-c\C-i" geiser-repl-import-module)
+  ("Add to load path..." "\C-c\C-r" geiser-add-to-load-path)
+  --
+  ("Previous matching input" "\M-p" comint-previous-matching-input-from-input
+   "Previous input matching current")
+  ("Next matching input" "\M-n" comint-next-matching-input-from-input
+   "Next input matching current")
+  ("Previous prompt" "\C-c\C-p" geiser-repl-previous-prompt)
+  ("Next prompt" "\C-c\C-n" geiser-repl-next-prompt)
+  ("Previous input" "\C-c\M-p" comint-previous-input)
+  ("Next input" "\C-c\M-n" comint-next-input)
+  --
+  ("Interrupt evaluation" ("\C-c\C-k" "\C-c\C-c" "\C-ck")
+   geiser-repl-interrupt)
+  --
+  (mode "Autodoc mode" ("\C-c\C-da" "\C-c\C-d\C-a") geiser-autodoc-mode)
+  ("Symbol documentation" ("\C-c\C-dd" "\C-c\C-d\C-d")
+   geiser-doc-symbol-at-point
+   "Documentation for symbol at point" :enable (geiser--symbol-at-point))
+  ("Lookup symbol in manul" ("\C-c\C-di" "\C-c\C-d\C-i")
+   geiser-doc-look-up-manual
+   "Documentation for symbol at point" :enable (geiser--symbol-at-point))
+  ("Module documentation" ("\C-c\C-dm" "\C-c\C-d\C-m") geiser-repl--doc-module
+   "Documentation for module at point" :enable (geiser--symbol-at-point))
+  --
+  ("Clear buffer" "\C-c\M-o" geiser-repl-clear-buffer
+   "Clean up REPL buffer, leaving just a lonely prompt")
+  ("Kill Scheme interpreter" "\C-c\C-q" geiser-repl-exit
+   :enable (geiser-repl--live-p))
+  ("Restart" "\C-c\C-z" switch-to-geiser :enable (not (geiser-repl--live-p)))
+  --
+  (custom "REPL options" geiser-repl))
+
+(define-key geiser-repl-mode-map [menu-bar completion] 'undefined)
+
+
+;;; User commands
+
+(defun run-geiser (impl)
+  "Start a new Geiser REPL."
+  (interactive
+   (list (geiser-repl--get-impl "Start Geiser for scheme implementation: ")))
+  (let ((buffer (current-buffer)))
+    (geiser-repl--start-repl impl nil)
+    (geiser-repl--maybe-remember-scm-buffer buffer)))
+
+(defalias 'geiser 'run-geiser)
+
+(defun geiser-connect (impl &optional host port)
+  "Start a new Geiser REPL connected to a remote Scheme process."
+  (interactive
+   (list (geiser-repl--get-impl "Connect to Scheme implementation: ")))
+  (let ((buffer (current-buffer)))
+    (geiser-repl--start-repl impl
+                             (geiser-repl--read-address host port))
+    (geiser-repl--maybe-remember-scm-buffer buffer)))
+
+(defun geiser-connect-local (impl socket)
+  "Start a new Geiser REPL connected to a remote Scheme process
+over a Unix-domain socket."
+  (interactive
+   (list (geiser-repl--get-impl "Connect to Scheme implementation: ")
+         (expand-file-name (read-file-name "Socket file name: "))))
+  (let ((buffer (current-buffer)))
+    (geiser-repl--start-repl impl socket)
+    (geiser-repl--maybe-remember-scm-buffer buffer)))
+
+(make-variable-buffer-local
+ (defvar geiser-repl--last-scm-buffer nil))
+
+(defun geiser-repl--maybe-remember-scm-buffer (buffer)
+  (when (and buffer
+             (eq 'scheme-mode (with-current-buffer buffer major-mode))
+             (eq major-mode 'geiser-repl-mode))
+    (setq geiser-repl--last-scm-buffer buffer)))
+
+(defun switch-to-geiser (&optional ask impl buffer)
+  "Switch to running Geiser REPL.
+
+If REPL is the current buffer, switch to the previously used
+scheme buffer.
+
+With prefix argument, ask for which one if more than one is running.
+If no REPL is running, execute `run-geiser' to start a fresh one."
+  (interactive "P")
+  (let* ((impl (or impl geiser-impl--implementation))
+         (in-repl (eq major-mode 'geiser-repl-mode))
+         (in-live-repl (and in-repl (get-buffer-process (current-buffer))))
+         (repl (unless ask
+                 (if impl
+                     (geiser-repl--repl/impl impl)
+                   (or geiser-repl--repl (car geiser-repl--repls))))))
+    (cond (in-live-repl
+           (when (and (not (eq repl buffer))
+                      (buffer-live-p geiser-repl--last-scm-buffer))
+             (geiser-repl--switch-to-buffer geiser-repl--last-scm-buffer)))
+          (repl (geiser-repl--switch-to-buffer repl))
+          ((geiser-repl--remote-p)
+           (geiser-connect impl (geiser-repl--host) (geiser-repl--port)))
+          ((geiser-repl--local-p)
+           (geiser-connect-local impl geiser-repl--address))
+	  (impl (run-geiser impl))
+          (t (call-interactively 'run-geiser)))
+    (geiser-repl--maybe-remember-scm-buffer buffer)))
+
+(defun switch-to-geiser-module (&optional module buffer)
+  "Switch to running Geiser REPL and try to enter a given module."
+  (interactive)
+  (let* ((module (or module
+                     (geiser-completion--read-module
+                      "Switch to module (default top-level): ")))
+         (cmd (and module
+                   (geiser-repl--enter-cmd geiser-impl--implementation
+                                           module))))
+    (unless (eq major-mode 'geiser-repl-mode)
+      (switch-to-geiser nil nil (or buffer (current-buffer))))
+    (geiser-repl--send cmd)))
+
+(defun geiser-repl-import-module (&optional module)
+  "Import a given module in the current namespace of the REPL."
+  (interactive)
+  (let* ((module (or module
+                     (geiser-completion--read-module "Import module: ")))
+         (cmd (and module
+                   (geiser-repl--import-cmd geiser-impl--implementation
+                                            module))))
+    (switch-to-geiser nil nil (current-buffer))
+    (geiser-repl--send cmd)))
+
+(defun geiser-repl-exit (&optional arg)
+  "Exit the current REPL.
+With a prefix argument, force exit by killing the scheme process."
+  (interactive "P")
+  (when (or (not geiser-repl-query-on-exit-p)
+            (y-or-n-p "Really quit this REPL? "))
+    (geiser-con--connection-deactivate geiser-repl--connection t)
+    (let ((cmd (and (not arg)
+                    (geiser-repl--exit-cmd geiser-impl--implementation))))
+      (if cmd
+          (when (stringp cmd) (geiser-repl--send cmd))
+        (comint-kill-subjob)))))
+
+(defun geiser-repl-next-prompt (n)
+  (interactive "p")
+  (when (> n 0)
+    (end-of-line)
+    (re-search-forward comint-prompt-regexp nil 'go n)))
+
+(defun geiser-repl-previous-prompt (n)
+  (interactive "p")
+  (when (> n 0)
+    (end-of-line 0)
+    (when (re-search-backward comint-prompt-regexp nil 'go n)
+      (goto-char (match-end 0)))))
+
+
+;;; Unload:
+
+(defun geiser-repl--repl-list ()
+  (let (lst)
+    (dolist (repl geiser-repl--repls lst)
+      (when (buffer-live-p repl)
+        (with-current-buffer repl
+          (push (cons geiser-impl--implementation
+                      geiser-repl--address)
+                lst))))))
+
+(defun geiser-repl--restore (impls)
+  (dolist (impl impls)
+    (when impl
+      (condition-case err
+          (geiser-repl--start-repl (car impl) (cdr impl))
+        (error (message (error-message-string err)))))))
+
+(defun geiser-repl-unload-function ()
+  (dolist (repl geiser-repl--repls)
+    (when (buffer-live-p repl)
+      (with-current-buffer repl
+        (let ((geiser-repl-query-on-exit-p nil)) (geiser-repl-exit))
+        (sit-for 0.05)
+        (kill-buffer)))))
+
+
+(provide 'geiser-repl)
+
+
+;;; Initialization:
+;; After providing 'geiser-repl, so that impls can use us.
+(mapc 'geiser-impl--load-impl geiser-active-implementations)

elpa/geiser-20171010.1610/geiser-syntax.el

@@ -0,0 +1,507 @@
+;;; geiser-syntax.el -- utilities for parsing scheme syntax
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio Ortega Ruiz
+
+;; 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 Feb 08, 2009 15:03
+
+
+
+(require 'geiser-impl)
+(require 'geiser-popup)
+(require 'geiser-base)
+
+(require 'scheme)
+
+(eval-when-compile (require 'cl))
+
+
+;;; Indentation:
+
+(defmacro geiser-syntax--scheme-indent (&rest pairs)
+  `(progn ,@(mapcar (lambda (p)
+                      `(put ',(car p) 'scheme-indent-function ',(cadr p)))
+                    pairs)))
+
+(geiser-syntax--scheme-indent
+ (and-let* 1)
+ (case-lambda 0)
+ (catch defun)
+ (class defun)
+ (dynamic-wind 0)
+ (guard 1)
+ (let*-values 1)
+ (let-values 1)
+ (let/ec 1)
+ (letrec* 1)
+ (match 1)
+ (match-lambda 0)
+ (match-lambda* 0)
+ (match-let scheme-let-indent)
+ (match-let* 1)
+ (match-letrec 1)
+ (opt-lambda 1)
+ (parameterize 1)
+ (parameterize* 1)
+ (receive 2)
+ (require-extension 0)
+ (syntax-case 2)
+ (test-approximate 1)
+ (test-assert 1)
+ (test-eq 1)
+ (test-equal 1)
+ (test-eqv 1)
+ (test-group-with-cleanup 1)
+ (test-runner-on-bad-count! 1)
+ (test-runner-on-bad-end-name! 1)
+ (test-runner-on-final! 1)
+ (test-runner-on-group-begin! 1)
+ (test-runner-on-group-end! 1)
+ (test-runner-on-test-begin! 1)
+ (test-runner-on-test-end! 1)
+ (test-with-runner 1)
+ (unless 1)
+ (when 1)
+ (while 1)
+ (with-exception-handler 1)
+ (with-syntax 1))
+
+
+;;; Extra syntax keywords
+
+(defconst geiser-syntax--builtin-keywords
+  '("and-let*"
+    "cut"
+    "cute"
+    "define-condition-type"
+    "define-immutable-record-type"
+    "define-record-type"
+    "define-values"
+    "letrec*"
+    "match"
+    "match-lambda"
+    "match-lambda*"
+    "match-let"
+    "match-let*"
+    "match-letrec"
+    "parameterize"
+    "receive"
+    "require-extension"
+    "set!"
+    "syntax-case"
+    "test-approximate"
+    "test-assert"
+    "test-begin"
+    "test-end"
+    "test-eq"
+    "test-equal"
+    "test-eqv"
+    "test-error"
+    "test-group"
+    "test-group-with-cleanup"
+    "test-with-runner"
+    "unless"
+    "when"
+    "with-exception-handler"
+    "with-input-from-file"
+    "with-output-to-file"))
+
+(defun geiser-syntax--simple-keywords (keywords)
+  "Return `font-lock-keywords' to highlight scheme KEYWORDS.
+KEYWORDS should be a list of strings."
+  (when keywords
+    `((,(format "[[(]%s\\>" (regexp-opt keywords 1)) . 1))))
+
+(defun geiser-syntax--keywords ()
+  (append
+   (geiser-syntax--simple-keywords geiser-syntax--builtin-keywords)
+   `(("\\[\\(else\\)\\>" . 1)
+     (,(rx "(" (group "define-syntax-rule") eow (* space)
+           (? "(") (? (group (1+ word))))
+      (1 font-lock-keyword-face)
+      (2 font-lock-function-name-face nil t)))))
+
+(font-lock-add-keywords 'scheme-mode (geiser-syntax--keywords))
+
+(geiser-impl--define-caller geiser-syntax--impl-kws keywords ()
+  "A variable (or thunk returning a value) giving additional,
+implementation-specific entries for font-lock-keywords.")
+
+(geiser-impl--define-caller geiser-syntax--case-sensitive case-sensitive ()
+  "A flag saying whether keywords are case sensitive.")
+
+(defun geiser-syntax--add-kws (&optional global-p)
+  (unless (bound-and-true-p quack-mode)
+    (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation))
+          (cs (geiser-syntax--case-sensitive geiser-impl--implementation)))
+      (when kw (font-lock-add-keywords nil kw))
+      (when global-p (font-lock-add-keywords nil (geiser-syntax--keywords)))
+      (setq font-lock-keywords-case-fold-search (not cs)))))
+
+(defun geiser-syntax--remove-kws ()
+  (unless (bound-and-true-p quack-mode)
+    (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation)))
+      (when kw
+        (font-lock-remove-keywords nil kw)))))
+
+
+;;; A simple scheme reader
+
+(defvar geiser-syntax--read/buffer-limit nil)
+
+(defsubst geiser-syntax--read/eos ()
+  (or (eobp)
+      (and geiser-syntax--read/buffer-limit
+           (<= geiser-syntax--read/buffer-limit (point)))))
+
+(defsubst geiser-syntax--read/next-char ()
+  (unless (geiser-syntax--read/eos)
+    (forward-char)
+    (char-after)))
+
+(defsubst geiser-syntax--read/token (token)
+  (geiser-syntax--read/next-char)
+  (if (listp token) token (list token)))
+
+(defsubst geiser-syntax--read/elisp ()
+  (ignore-errors (read (current-buffer))))
+
+(defun geiser-syntax--read/symbol ()
+  (with-syntax-table scheme-mode-syntax-table
+    (when (re-search-forward "\\(\\sw\\|\\s_\\)+" nil t)
+      (make-symbol (match-string-no-properties 0)))))
+
+(defun geiser-syntax--read/matching (open close)
+  (let ((count 1)
+        (p (1+ (point))))
+    (while (and (> count 0)
+                (geiser-syntax--read/next-char))
+      (cond ((looking-at-p open) (setq count (1+ count)))
+            ((looking-at-p close) (setq count (1- count)))))
+    (buffer-substring-no-properties p (point))))
+
+(defsubst geiser-syntax--read/unprintable ()
+  (geiser-syntax--read/token
+   (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
+
+(defun geiser-syntax--read/skip-comment ()
+  (while (and (geiser-syntax--read/next-char)
+              (nth 8 (syntax-ppss))))
+  (geiser-syntax--read/next-token))
+
+(defun geiser-syntax--read/next-token ()
+  (skip-syntax-forward "->")
+  (if (geiser-syntax--read/eos) '(eob)
+    (case (char-after)
+      (?\; (geiser-syntax--read/skip-comment))
+      ((?\( ?\[) (geiser-syntax--read/token 'lparen))
+      ((?\) ?\]) (geiser-syntax--read/token 'rparen))
+      (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
+              (geiser-syntax--read/token 'dot)
+            (cons 'atom (geiser-syntax--read/elisp))))
+      (?\# (case (geiser-syntax--read/next-char)
+             ('nil '(eob))
+             (?| (geiser-syntax--read/skip-comment))
+             (?: (if (geiser-syntax--read/next-char)
+                     (cons 'kwd (geiser-syntax--read/symbol))
+                   '(eob)))
+             (?\\ (cons 'char (geiser-syntax--read/elisp)))
+             (?\( (geiser-syntax--read/token 'vectorb))
+             (?\< (geiser-syntax--read/unprintable))
+             ((?' ?` ?,) (geiser-syntax--read/next-token))
+             (t (let ((tok (geiser-syntax--read/symbol)))
+                  (cond ((equal (symbol-name tok) "t") '(boolean . :t))
+                        ((equal (symbol-name tok) "f") '(boolean . :f))
+                        (tok (cons 'atom tok))
+                        (t (geiser-syntax--read/next-token)))))))
+      (?\' (geiser-syntax--read/token '(quote . quote)))
+      (?\` (geiser-syntax--read/token
+            `(backquote . ,backquote-backquote-symbol)))
+      (?, (if (eq (geiser-syntax--read/next-char) ?@)
+              (geiser-syntax--read/token
+               `(splice . ,backquote-splice-symbol))
+            `(unquote . ,backquote-unquote-symbol)))
+      (?\" (cons 'string (geiser-syntax--read/elisp)))
+      (t (cons 'atom (geiser-syntax--read/symbol))))))
+
+(defsubst geiser-syntax--read/match (&rest tks)
+  (let ((token (geiser-syntax--read/next-token)))
+    (if (memq (car token) tks) token
+      (error "Unexpected token: %s" token))))
+
+(defsubst geiser-syntax--read/skip-until (&rest tks)
+  (let (token)
+    (while (and (not (memq (car token) tks))
+                (not (eq (car token) 'eob)))
+      (setq token (geiser-syntax--read/next-token)))
+    token))
+
+(defsubst geiser-syntax--read/try (&rest tks)
+  (let ((p (point))
+        (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
+    (unless tk (goto-char p))
+    tk))
+
+(defun geiser-syntax--read/list ()
+  (cond ((geiser-syntax--read/try 'dot)
+         (let ((tail (geiser-syntax--read)))
+           (geiser-syntax--read/skip-until 'eob 'rparen)
+           tail))
+        ((geiser-syntax--read/try 'rparen 'eob) nil)
+        (t (cons (geiser-syntax--read)
+                 (geiser-syntax--read/list)))))
+
+(defun geiser-syntax--read ()
+  (let ((token (geiser-syntax--read/next-token))
+        (max-lisp-eval-depth (max max-lisp-eval-depth 3000)))
+    (case (car token)
+      (eob nil)
+      (lparen (geiser-syntax--read/list))
+      (vectorb (apply 'vector (geiser-syntax--read/list)))
+      ((quote backquote unquote splice) (list (cdr token)
+                                              (geiser-syntax--read)))
+      (kwd (make-symbol (format ":%s" (cdr token))))
+      (unprintable (format "#<%s>" (cdr token)))
+      ((char string atom) (cdr token))
+      (boolean (cdr token))
+      (t (error "Reading scheme syntax: unexpected token: %s" token)))))
+
+(defun geiser-syntax--read-from-string (string &optional start end)
+  (when (stringp string)
+    (let* ((start (or start 0))
+           (end (or end (length string)))
+           (max-lisp-eval-depth (min 20000
+                                     (max max-lisp-eval-depth (- end start)))))
+      (with-temp-buffer
+        (save-excursion (insert string))
+        (cons (ignore-errors (geiser-syntax--read)) (point))))))
+
+(defun geiser-syntax--form-from-string (s)
+  (car (geiser-syntax--read-from-string s)))
+
+(defsubst geiser-syntax--form-after-point (&optional boundary)
+  (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
+    (save-excursion (values (geiser-syntax--read) (point)))))
+
+(defun geiser-syntax--mapconcat (fun lst sep)
+  (cond ((null lst) "")
+        ((not (listp lst)) (format ".%s%s" sep (funcall fun lst)))
+        ((null (cdr lst)) (format "%s" (funcall fun (car lst))))
+        (t (format "%s%s%s"
+                   (funcall fun (car lst))
+                   sep
+                   (geiser-syntax--mapconcat fun (cdr lst) sep)))))
+
+
+;;; Code parsing:
+
+(defsubst geiser-syntax--symbol-at-point ()
+  (and (not (nth 8 (syntax-ppss)))
+       (car (geiser-syntax--read-from-string (thing-at-point 'symbol)))))
+
+(defsubst geiser-syntax--skip-comment/string ()
+  (let ((pos (nth 8 (syntax-ppss))))
+    (goto-char (or pos (point)))
+    pos))
+
+(defsubst geiser-syntax--nesting-level ()
+  (or (nth 0 (syntax-ppss)) 0))
+
+(defun geiser-syntax--pop-to-top ()
+  (ignore-errors
+    (while (> (geiser-syntax--nesting-level) 0) (backward-up-list))))
+
+(defsubst geiser-syntax--in-string-p ()
+  (nth 3 (syntax-ppss)))
+
+(defsubst geiser-syntax--pair-length (p)
+  (if (cdr (last p)) (1+ (safe-length p)) (length p)))
+
+(defun geiser-syntax--shallow-form (boundary)
+  (when (looking-at-p "\\s(")
+    (save-excursion
+      (forward-char)
+      (let ((elems))
+        (ignore-errors
+          (while (< (point) boundary)
+            (skip-syntax-forward "-<>")
+            (when (<= (point) boundary)
+              (forward-sexp)
+              (let ((s (thing-at-point 'symbol)))
+                (unless (equal "." s)
+                  (push (car (geiser-syntax--read-from-string s)) elems))))))
+        (nreverse elems)))))
+
+(defsubst geiser-syntax--keywordp (s)
+  (and s (symbolp s) (string-match "^:.+" (symbol-name s))))
+
+(defsubst geiser-syntax--symbol-eq (s0 s1)
+  (and (symbolp s0) (symbolp s1) (equal (symbol-name s0) (symbol-name s1))))
+
+(defun geiser-syntax--scan-sexps (&optional begin)
+  (let* ((fst (geiser-syntax--symbol-at-point))
+         (smth (or fst (not (looking-at-p "[\s \s)\s>\s<\n]"))))
+         (path (and fst `((,fst 0)))))
+    (save-excursion
+      (while (> (or (geiser-syntax--nesting-level) 0) 0)
+        (let ((boundary (point)))
+          (geiser-syntax--skip-comment/string)
+          (backward-up-list)
+          (let ((form (geiser-syntax--shallow-form boundary)))
+            (when (and (listp form) (car form) (symbolp (car form)))
+              (let* ((len (geiser-syntax--pair-length form))
+                     (pos (if smth (1- len) (progn (setq smth t) len)))
+                     (prev (and (> pos 1) (nth (1- pos) form)))
+                     (prev (and (geiser-syntax--keywordp prev)
+                                (list prev))))
+                (push `(,(car form) ,pos ,@prev) path)))))))
+    (mapcar (lambda (e)
+              (cons (substring-no-properties (format "%s" (car e))) (cdr e)))
+            (nreverse path))))
+
+(defsubst geiser-syntax--binding-form-p (bfs sbfs f)
+  (and (symbolp f)
+       (let ((f (symbol-name f)))
+         (or (member f '("define" "define*" "define-syntax"
+                         "syntax-rules" "lambda" "case-lambda"
+                         "let" "let*" "let-values" "let*-values"
+                         "letrec" "letrec*" "parameterize"))
+             (member f bfs)
+             (member f sbfs)))))
+
+(defsubst geiser-syntax--binding-form*-p (sbfs f)
+  (and (symbolp f)
+       (let ((f (symbol-name f)))
+         (or (member f '("let*" "let*-values" "letrec" "letrec*"))
+             (member f sbfs)))))
+
+(defsubst geiser-syntax--if-symbol (x) (and (symbolp x) x))
+(defsubst geiser-syntax--if-list (x) (and (listp x) x))
+
+(defsubst geiser-syntax--normalize (vars)
+  (mapcar (lambda (i)
+            (let ((i (if (listp i) (car i) i)))
+              (and (symbolp i) (symbol-name i))))
+          vars))
+
+(defun geiser-syntax--linearize (form)
+  (cond ((not (listp form)) (list form))
+	((null form) nil)
+	(t (cons (car form) (geiser-syntax--linearize (cdr form))))))
+
+(defun geiser-syntax--scan-locals (bfs sbfs form nesting locals)
+  (if (or (null form) (not (listp form)))
+      (geiser-syntax--normalize locals)
+    (if (not (geiser-syntax--binding-form-p bfs sbfs (car form)))
+	(geiser-syntax--scan-locals bfs sbfs
+				    (car (last form))
+                                    (1- nesting) locals)
+      (let* ((head (car form))
+	     (name (geiser-syntax--if-symbol (cadr form)))
+	     (names (if name (geiser-syntax--if-list (caddr form))
+		      (geiser-syntax--if-list (cadr form))))
+             (bns (and name
+                       (geiser-syntax--binding-form-p bfs sbfs (car names))))
+	     (rest (if (and name (not bns)) (cdddr form) (cddr form)))
+	     (use-names (and (or rest
+                                 (< nesting 1)
+                                 (geiser-syntax--binding-form*-p sbfs head))
+                             (not bns))))
+	(when name (push name locals))
+        (when (geiser-syntax--symbol-eq head 'case-lambda)
+          (dolist (n (and (> nesting 0) (caar (last form))))
+            (when n (push n locals)))
+          (setq rest (and (> nesting 0) (cdr form)))
+          (setq use-names nil))
+        (when (geiser-syntax--symbol-eq head 'syntax-rules)
+          (dolist (n (and (> nesting 0) (cdaar (last form))))
+            (when n (push n locals)))
+          (setq rest (and (> nesting 0) (cdr form))))
+	(when use-names
+	  (dolist (n (geiser-syntax--linearize names))
+            (let ((xs (if (and (listp n) (listp (car n))) (car n) (list n))))
+              (dolist (x xs) (when x (push x locals))))))
+	(dolist (f (butlast rest))
+	  (when (and (listp f)
+                     (geiser-syntax--symbol-eq (car f) 'define)
+                     (cadr f))
+	    (push (cadr f) locals)))
+	(geiser-syntax--scan-locals bfs sbfs
+				    (car (last (or rest names)))
+                                    (1- nesting)
+				    locals)))))
+
+(defun geiser-syntax--locals-around-point (bfs sbfs)
+  (when (eq major-mode 'scheme-mode)
+    (save-excursion
+      (let ((sym (unless (geiser-syntax--skip-comment/string)
+                   (thing-at-point 'symbol))))
+        (skip-syntax-forward "->")
+        (let ((boundary (point))
+              (nesting (geiser-syntax--nesting-level)))
+          (geiser-syntax--pop-to-top)
+          (multiple-value-bind (form end)
+              (geiser-syntax--form-after-point boundary)
+            (delete sym
+                    (geiser-syntax--scan-locals bfs
+                                                sbfs
+                                                form
+                                                (1- nesting)
+                                                '()))))))))
+
+
+;;; Display and fontify strings as Scheme code:
+
+(defun geiser-syntax--display (a)
+  (cond ((null a) "()")
+        ((eq a :t) "#t")
+        ((eq a :f) "#f")
+        ((geiser-syntax--keywordp a) (format "#%s" a))
+        ((symbolp a) (format "%s" a))
+        ((equal a "...") "...")
+        ((stringp a) (format "%S" a))
+        ((and (listp a) (symbolp (car a))
+              (equal (symbol-name (car a)) "quote"))
+         (format "'%s" (geiser-syntax--display (cadr a))))
+        ((listp a)
+         (format "(%s)"
+                 (geiser-syntax--mapconcat 'geiser-syntax--display a " ")))
+        (t (format "%s" a))))
+
+(defconst geiser-syntax--font-lock-buffer-name " *geiser font lock*")
+
+(defun geiser-syntax--font-lock-buffer-p (&optional buffer)
+  (equal (buffer-name buffer) geiser-syntax--font-lock-buffer-name))
+
+(defun geiser-syntax--font-lock-buffer ()
+  (or (get-buffer geiser-syntax--font-lock-buffer-name)
+      (let ((buffer (get-buffer-create geiser-syntax--font-lock-buffer-name)))
+        (set-buffer buffer)
+        (let ((geiser-default-implementation
+               (or geiser-default-implementation
+                   (car geiser-active-implementations))))
+          (scheme-mode))
+        buffer)))
+
+(defun geiser-syntax--fontify (&optional beg end)
+  (let ((font-lock-verbose nil)
+        (beg (or beg (point-min)))
+        (end (or end (point-max))))
+    (if (fboundp 'font-lock-flush)
+        (font-lock-flush beg end)
+      (with-no-warnings (font-lock-fontify-region beg end)))))
+
+(defun geiser-syntax--scheme-str (str)
+  (save-current-buffer
+    (set-buffer (geiser-syntax--font-lock-buffer))
+    (erase-buffer)
+    (insert str)
+    (geiser-syntax--fontify)
+    (buffer-string)))
+
+
+(provide 'geiser-syntax)

elpa/geiser-20171010.1610/geiser-table.el

@@ -0,0 +1,136 @@
+;;; geiser-table.el -- table creation
+
+;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Tue Jan 06, 2009 13:44
+
+
+
+(defun geiser-table--col-widths (rows)
+  (let* ((col-no (length (car rows)))
+         (available (- (window-width) 2 (* 2 col-no)))
+         (widths)
+         (c 0))
+    (while (< c col-no)
+      (let ((width 0)
+            (av-width (- available (* 5 (- col-no c)))))
+        (dolist (row rows)
+          (setq width
+                (min av-width
+                     (max width (length (nth c row))))))
+        (push width widths)
+        (setq available (- available width)))
+      (setq c (1+ c)))
+    (reverse widths)))
+
+(defun geiser-table--pad-str (str width)
+  (let ((len (length str)))
+    (cond ((= len width) str)
+          ((> len width) (concat (substring str 0 (- width 3)) "..."))
+          (t (concat str (make-string (- width (length str)) ?\ ))))))
+
+(defun geiser-table--str-lines (str width)
+  (if (<= (length str) width)
+      (list (geiser-table--pad-str str width))
+    (with-temp-buffer
+      (let ((fill-column width))
+        (insert str)
+        (fill-region (point-min) (point-max))
+        (mapcar (lambda (s) (geiser-table--pad-str s width))
+                (split-string (buffer-string) "\n"))))))
+
+(defun geiser-table--pad-row (row)
+  (let* ((max-ln (apply 'max (mapcar 'length row)))
+         (result))
+    (dolist (lines row)
+      (let ((ln (length lines)))
+        (if (= ln max-ln) (push lines result)
+          (let ((lines (reverse lines))
+                (l 0)
+                (blank (make-string (length (car lines)) ?\ )))
+            (while (< l ln)
+              (push blank lines)
+              (setq l (1+ l)))
+            (push (reverse lines) result)))))
+    (reverse result)))
+
+(defun geiser-table--format-rows (rows widths)
+  (let ((col-no (length (car rows)))
+        (frows))
+    (dolist (row rows)
+      (let ((c 0) (frow))
+        (while (< c col-no)
+          (push (geiser-table--str-lines (nth c row) (nth c widths)) frow)
+          (setq c (1+ c)))
+        (push (geiser-table--pad-row (reverse frow)) frows)))
+    (reverse frows)))
+
+(defvar geiser-table-corner-lt "┌")
+(defvar geiser-table-corner-lb "└")
+(defvar geiser-table-corner-rt "┐")
+(defvar geiser-table-corner-rb "┘")
+(defvar geiser-table-line "─")
+(defvar geiser-table-tee-t "┬")
+(defvar geiser-table-tee-b "┴")
+(defvar geiser-table-tee-l "├")
+(defvar geiser-table-tee-r "┤")
+(defvar geiser-table-crux "┼")
+(defvar geiser-table-sep "│")
+
+(defun geiser-table--insert-line (widths first last sep)
+  (insert first geiser-table-line)
+  (dolist (w widths)
+    (while (> w 0)
+      (insert geiser-table-line)
+      (setq w (1- w)))
+    (insert geiser-table-line sep geiser-table-line))
+  (delete-char -2)
+  (insert geiser-table-line last)
+  (newline))
+
+(defun geiser-table--insert-first-line (widths)
+  (geiser-table--insert-line widths
+                             geiser-table-corner-lt
+                             geiser-table-corner-rt
+                             geiser-table-tee-t))
+
+(defun geiser-table--insert-middle-line (widths)
+  (geiser-table--insert-line widths
+                             geiser-table-tee-l
+                             geiser-table-tee-r
+                             geiser-table-crux))
+
+(defun geiser-table--insert-last-line (widths)
+  (geiser-table--insert-line widths
+                             geiser-table-corner-lb
+                             geiser-table-corner-rb
+                             geiser-table-tee-b))
+
+(defun geiser-table--insert-row (r)
+  (let ((ln (length (car r)))
+        (l 0))
+    (while (< l ln)
+      (insert (concat geiser-table-sep " "
+                      (mapconcat 'identity
+                                 (mapcar `(lambda (x) (nth ,l x)) r)
+                                 (concat " " geiser-table-sep " "))
+                      "  " geiser-table-sep "\n"))
+      (setq l (1+ l)))))
+
+(defun geiser-table--insert (rows)
+  (let* ((widths (geiser-table--col-widths rows))
+         (rows (geiser-table--format-rows rows widths)))
+    (geiser-table--insert-first-line widths)
+    (dolist (r rows)
+      (geiser-table--insert-row r)
+      (geiser-table--insert-middle-line widths))
+    (kill-line -1)
+    (geiser-table--insert-last-line widths)))
+
+
+(provide 'geiser-table)

elpa/geiser-20171010.1610/geiser-version.el

@@ -0,0 +1,20 @@
+;;; geiser-version.el.in -- geiser's version
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; 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>.
+
+
+
+(defvar geiser-version-string "@PACKAGE_STRING@"
+  "Geiser's version as a string.")
+
+(defun geiser-version ()
+  "Echoes Geiser's version."
+  (interactive)
+  (message "%s" geiser-version-string))
+
+(provide 'geiser-version)

elpa/geiser-20171010.1610/geiser-xref.el

@@ -0,0 +1,165 @@
+;; geiser-xref.el -- utilities for cross-referencing
+
+;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Thu Mar 05, 2009 23:03
+
+
+
+(require' geiser-edit)
+(require 'geiser-autodoc)
+(require 'geiser-eval)
+(require 'geiser-popup)
+(require 'geiser-custom)
+(require 'geiser-base)
+
+(require 'button)
+(require 'lisp-mode)
+
+
+;;; Customization:
+(defgroup geiser-xref nil
+  "Options for cross-referencing commands."
+  :group 'geiser)
+
+(geiser-edit--define-custom-visit
+ geiser-xref-follow-link-method geiser-xref
+ "How to visit buffers when following xrefs.")
+
+(geiser-custom--defface xref-link
+  'link geiser-xref "links in cross-reference buffers")
+
+(geiser-custom--defface xref-header
+  'bold geiser-xref "headers in cross-reference buffers")
+
+
+;;; Buffer and mode:
+
+(geiser-popup--define xref "*Geiser xref*" geiser-xref-mode)
+
+(defvar geiser-xref-mode-map
+  (let ((map (make-sparse-keymap)))
+    (suppress-keymap map)
+    (set-keymap-parent map button-buffer-map)
+    map)
+  "Keymap for `geiser-xref-mode'.")
+
+(define-derived-mode geiser-xref-mode nil "Geiser Xref"
+  "Major mode for displaying cross-references.
+\\{geiser-xref-mode-map}"
+  (buffer-disable-undo)
+  (set-syntax-table scheme-mode-syntax-table)
+  (setq buffer-read-only t))
+
+
+;;; Ref button:
+
+(define-button-type 'geiser-xref--button
+  'action 'geiser-xref--button-action
+  'face 'geiser-font-lock-xref-link
+  'follow-link t)
+
+(defun geiser-xref--button-action (button)
+  (let ((location (button-get button 'location))
+        (name (button-get button 'name)))
+    (when location
+      (geiser-edit--try-edit-location name
+                                      location
+                                      geiser-xref-follow-link-method))))
+
+(defun geiser-xref--insert-button (xref)
+  (let* ((location (cdr (assoc "location" xref)))
+         (file (geiser-edit--location-file location))
+         (signature (cdr (assoc "signature" xref)))
+         (signature-txt (and signature
+                             (geiser-autodoc--str* signature)))
+         (module (cdr (assoc "module" xref)))
+         (p (point)))
+    (when signature
+      (insert "   - ")
+      (if (stringp file)
+          (insert-text-button signature-txt
+                              :type 'geiser-xref--button
+                              'location location
+                              'name (car signature)
+                              'help-echo (format "%s in %s"
+                                                 (car signature) file))
+        (insert (format "%s" signature-txt)))
+      (fill-region p (point))
+      (save-excursion (goto-char p) (indent-sexp))
+      (newline))))
+
+(defun geiser-xref--module< (xr1 xr2)
+  (let ((m1 (format "%s" (cdr (assoc "module" xr1))))
+        (m2 (format "%s" (cdr (assoc "module" xr2)))))
+    (cond ((equal m1 m2)
+           (string< (format "%s" (cdr (assoc "signature" xr1)))
+                    (format "%s" (cdr (assoc "signature" xr2)))))
+          ((null m1) (not m2))
+          ((null m2))
+          (t (string< (format "%s" m1) (format "%s" m2))))))
+
+(defun geiser-xref--display-xrefs (header xrefs)
+  (geiser-xref--with-buffer
+   (erase-buffer)
+   (geiser--insert-with-face header 'geiser-font-lock-xref-header)
+   (newline)
+   (let ((last-module))
+     (dolist (xref (sort xrefs 'geiser-xref--module<))
+       (let ((module (format "%s" (cdr (assoc "module" xref)))))
+         (when (not (equal module last-module))
+           (insert "\n  In module ")
+           (geiser--insert-with-face (format "%s" module)
+                                     'geiser-font-lock-xref-header)
+           (newline 2)
+           (setq last-module module))
+         (geiser-xref--insert-button xref)))))
+  (geiser-xref--pop-to-buffer)
+  (goto-char (point-min)))
+
+(defun geiser-xref--read-name (ask prompt)
+  (let ((name (or (and (not ask) (geiser--symbol-at-point))
+                  (read-string prompt nil nil (geiser--symbol-at-point)))))
+    (and name (format "%s" name))))
+
+(defun geiser-xref--fetch-xrefs (ask kind rkind proc)
+  (let* ((name (geiser-xref--read-name ask (format "%s: " (capitalize kind))))
+         (res (and name (geiser-eval--send/result
+                         `(:eval (:ge ,proc (quote (:scm ,name))))))))
+    (message "Retrieving %ss list for '%s'..." rkind name)
+    (if (or (not res) (not (listp res)))
+        (message "No %ss found for '%s'" rkind name)
+      (message "")
+      (geiser-xref--display-xrefs (format "%ss for '%s'"
+                                          (capitalize rkind)
+                                          name)
+                                  res))))
+
+
+;;; Commands:
+
+(defun geiser-xref-generic-methods (&optional arg)
+  "Display information about known methods of a given generic.
+With prefix, ask for the name of the generic."
+  (interactive "P")
+  (geiser-xref--fetch-xrefs arg "generic" "method" 'generic-methods))
+
+(defun geiser-xref-callers (&optional arg)
+  "Display list of callers for procedure at point.
+With prefix, ask for the procedure."
+  (interactive "P")
+  (geiser-xref--fetch-xrefs arg "procedure" "caller" 'callers))
+
+(defun geiser-xref-callees (&optional arg)
+  "Display list of callees for procedure at point.
+With prefix, ask for the procedure."
+  (interactive "P")
+  (geiser-xref--fetch-xrefs arg "procedure" "callee" 'callees))
+
+
+(provide 'geiser-xref)

elpa/geiser-20171010.1610/geiser.el

@@ -0,0 +1,168 @@
+;;; geiser.el --- GNU Emacs and Scheme talk to each other
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015 Jose Antonio Ortega Ruiz
+;; URL: http://www.nongnu.org/geiser/
+
+;; 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>.
+
+
+;; Autoloads and basic setup for geiser.
+
+;;; Locations:
+
+;;;###autoload
+(defconst geiser-elisp-dir (file-name-directory load-file-name)
+  "Directory containing Geiser's Elisp files.")
+
+;;;###autoload
+(defconst geiser-scheme-dir
+  (let ((d (expand-file-name "./scheme/" geiser-elisp-dir)))
+    (if (file-directory-p d)
+        d
+      (expand-file-name "../scheme/" geiser-elisp-dir)))
+  "Directory containing Geiser's Scheme files.")
+
+;;;###autoload
+(when (not (member geiser-elisp-dir load-path))
+  (add-to-list 'load-path geiser-elisp-dir))
+
+
+;;; Autoloads:
+
+;;;###autoload
+(autoload 'geiser-version "geiser-version" "Echo Geiser's version." t)
+
+;;;###autoload
+(autoload 'geiser-unload "geiser-reload" "Unload all Geiser code." t)
+
+;;;###autoload
+(autoload 'geiser-reload "geiser-reload" "Reload Geiser code." t)
+
+;;;###autoload
+(autoload 'geiser "geiser-repl"
+  "Start a Geiser REPL, or switch to a running one." t)
+
+;;;###autoload
+(autoload 'run-geiser "geiser-repl" "Start a Geiser REPL." t)
+
+;;;###autoload
+(autoload 'geiser-connect "geiser-repl"
+  "Start a Geiser REPL connected to a remote server." t)
+
+;;;###autoload
+(autoload 'geiser-connect-local "geiser-repl"
+  "Start a Geiser REPL connected to a remote server over a Unix-domain socket."
+  t)
+
+;;;###autoload
+(autoload 'switch-to-geiser "geiser-repl"
+  "Switch to a running one Geiser REPL." t)
+
+;;;###autoload
+(autoload 'run-chez "geiser-chez" "Start a Geiser Chez REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-chez "geiser-chez"
+  "Start a Geiser Chez REPL, or switch to a running one." t)
+
+;;;###autoload
+(autoload 'run-guile "geiser-guile" "Start a Geiser Guile REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-guile "geiser-guile"
+  "Start a Geiser Guile REPL, or switch to a running one." t)
+
+;;;###autoload
+(autoload 'connect-to-guile "geiser-guile"
+  "Connect to a remote Geiser Guile REPL." t)
+
+;;;###autoload
+(autoload 'run-racket "geiser-racket" "Start a Geiser Racket REPL." t)
+
+;;;###autoload
+(autoload 'run-gracket "geiser-racket" "Start a Geiser GRacket REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-racket "geiser-racket"
+  "Start a Geiser Racket REPL, or switch to a running one." t)
+
+;;;###autoload
+(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 '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 'run-chibi "geiser-chibi" "Start a Geiser Chibi Scheme REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-chibi "geiser-chibi"
+  "Start a Geiser Chibi 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)
+
+;;;###autoload
+(autoload 'turn-on-geiser-mode "geiser-mode"
+  "Enable Geiser's mode (useful in Scheme buffers)." t)
+
+;;;###autoload
+(autoload 'turn-off-geiser-mode "geiser-mode"
+  "Disable Geiser's mode (useful in Scheme buffers)." t)
+
+;;;###autoload
+(autoload 'geiser-mode--maybe-activate "geiser-mode")
+
+;;;###autoload
+(mapc (lambda (group)
+        (custom-add-load group (symbol-name group))
+        (custom-add-load 'geiser (symbol-name group)))
+      '(geiser
+        geiser-repl
+        geiser-autodoc
+        geiser-doc
+        geiser-debug
+        geiser-faces
+        geiser-mode
+        geiser-guile
+        geiser-image
+        geiser-racket
+        geiser-chicken
+	geiser-chez
+	geiser-chibi
+	geiser-mit
+        geiser-implementation
+        geiser-xref))
+
+
+;;; Setup:
+
+;;;###autoload
+(add-hook 'scheme-mode-hook 'geiser-mode--maybe-activate)
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.rkt\\'" . scheme-mode))
+
+
+(provide 'geiser)
+
+;;; geiser.el ends here

elpa/geiser-20171010.1610/macros.info

@@ -0,0 +1,7 @@
+This is macros.info, produced by makeinfo version 5.2 from macros.texi.
+
+
+
+Tag Table:
+
+End Tag Table

elpa/geiser-20171010.1610/scheme/chez/geiser/geiser.ss

@@ -0,0 +1,135 @@
+(library (geiser)
+  (export geiser:eval
+          geiser:completions
+          geiser:module-completions
+          geiser:autodoc
+          geiser:no-values
+          geiser:newline)
+  (import (chezscheme))
+
+  (define string-prefix?
+    (lambda (x y)
+      (let ([n (string-length x)])
+        (and (fx<= n (string-length y))
+             (let prefix? ([i 0])
+               (or (fx= i n)
+                   (and (char=? (string-ref x i) (string-ref y i))
+                        (prefix? (fx+ i 1)))))))))
+
+  (define (geiser:completions prefix . rest)
+    rest
+    (sort string-ci<?
+          (filter (lambda (el)
+                    (string-prefix? prefix el))
+                  (map write-to-string (environment-symbols (interaction-environment))))))
+
+  (define (write-to-string x)
+    (with-output-to-string
+      (lambda ()
+        (write x))))
+
+  (define (geiser:eval module form . rest)
+    rest
+    (let* ((body (lambda ()
+		   (if module
+		       (eval form (environment module))
+		       (eval form))))
+	   (gen-result (lambda (result-mid is-error?)
+			 (if is-error?
+			     `((result "")
+			       (output . "")
+			       (error . ,(list
+					(cons 'key
+					      (with-output-to-string
+						(lambda ()
+						  (display-condition result-mid)))))))
+			     `((result ,(with-output-to-string
+					  (lambda ()
+					    (pretty-print result-mid))))
+			       (output . "")))))
+	   (result (call/cc
+		    (lambda (k)
+		      (with-exception-handler
+			  (lambda (e)
+			    (k (gen-result e #t)))
+			(lambda ()
+			  (call-with-values
+			      (lambda ()
+				(body))
+			    (lambda (x . y)
+			      (if (null? y)
+				  (k (gen-result x #f))
+				  (k (gen-result (cons x y) #f)))))))))))
+      (write result)
+      (newline)))
+
+  (define (geiser:module-completions prefix . rest)
+    (define (substring? s1 s2)
+      (let ([n1 (string-length s1)] [n2 (string-length s2)])
+        (let loop2 ([i2 0])
+          (let loop1 ([i1 0] [j i2])
+            (if (fx= i1 n1)
+                i2
+                (and (not (fx= j n2))
+                     (if (char=? (string-ref s1 i1) (string-ref s2 j))
+                         (loop1 (fx+ i1 1) (fx+ j 1))
+                         (loop2 (fx+ i2 1)))))))))
+    (filter (lambda (el)
+              (substring? prefix el))
+            (map write-to-string (library-list))))
+
+  (define (procedure-parameter-list p)
+    ;; same as (inspect object), then hitting c
+    (let ((s (((inspect/object p) 'code) 'source)))
+      (if s
+          (let ((form (s 'value)))
+            (if (and (list? form)
+                     (> (length form) 2)
+                     (eq? (car form) 'lambda))
+                (cadr form)
+                #f))
+          #f)))
+
+  (define (operator-arglist operator)
+    (let ((binding (eval operator)))
+      (if binding
+          (let ((arglist (procedure-parameter-list binding)))
+            (let loop ((arglist 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))))
+                    (else
+                     (loop
+                      (cdr arglist)
+                      optionals?
+                      (if optionals? required (cons (car arglist) required))
+                      (if optionals? (cons (car arglist) optional) optional))))))
+          '())))
+
+  (define (geiser:autodoc ids . rest)
+    (cond ((null? ids) '())
+          ((not (list? ids))
+           (geiser:autodoc (list ids)))
+          ((not (symbol? (car ids)))
+           (geiser:autodoc (cdr ids)))
+          (else
+           (map (lambda (id)
+                  (operator-arglist id))
+                ids))))
+
+  (define (geiser:no-values)
+    #f)
+
+  (define (geiser:newline)
+    #f))

elpa/geiser-20171010.1610/scheme/chez/geiser/test.ss

@@ -0,0 +1,90 @@
+(import (geiser)
+	(chezscheme))
+
+
+(define-syntax get-result
+  (syntax-rules ()
+    ((_ form)
+     (with-output-to-string
+       (lambda ()
+	 (geiser:eval #f form))))))
+
+(define-syntax do-test
+  (syntax-rules ()
+    ((_ form result)
+     (assert
+      (equal?
+       (get-result form)
+       result)))))
+
+;; (something-doesnot-exist)
+;;=> Error: Exception: variable something-doesnot-exist is not bound
+(do-test
+ '(something-doesnot-exist)
+ "((result \"\") (output . \"\") (error (key . \"Exception: variable something-doesnot-exist is not bound\")))\n"
+ )
+
+;; (make-violation)
+;;=> #<condition &violation>
+(do-test
+ '(make-violation) 
+ "((result \"#<condition &violation>\\n\") (output . \"\"))\n")
+
+;; (values 1 2 3)
+;;==> (1 2 3)
+(do-test
+ '(values 1 2 3)
+ "((result \"(1 2 3)\\n\") (output . \"\"))\n")
+
+;; 1
+;;=> 1
+(do-test '1 "((result \"1\\n\") (output . \"\"))\n")
+
+
+;; '(case-lambda
+;;    [(x1 x2) (+ x1 x2)]
+;;    [(x1 x2 x3) (+ (+ x1 x2) x3)]
+;;    [(x1 x2 . rest)
+;;     ((letrec ([loop (lambda (x1 x2 rest)
+;; 		      (let ([x (+ x1 x2)])
+;; 			(if (null? rest)
+;; 			    x
+;; 			    (loop x (car rest) (cdr rest)))))])
+;;        loop)
+;;      x1
+;;      x2
+;;      rest)]
+;;    [(x1) (+ x1)]
+;;    [() (+)])
+#|=> (case-lambda
+  [(x1 x2) (+ x1 x2)]
+  [(x1 x2 x3) (+ (+ x1 x2) x3)]
+  [(x1 x2 . rest)
+   ((letrec ([loop (lambda (x1 x2 rest)
+                     (let ([x (+ x1 x2)])
+                       (if (null? rest)
+                           x
+                           (loop x (car rest) (cdr rest)))))])
+      loop)
+     x1
+     x2
+     rest)]
+  [(x1) (+ x1)]
+  [() (+)])
+  |#
+(do-test (quote '(case-lambda
+  [(x1 x2) (+ x1 x2)]
+  [(x1 x2 x3) (+ (+ x1 x2) x3)]
+  [(x1 x2 . rest)
+   ((letrec ([loop (lambda (x1 x2 rest)
+                     (let ([x (+ x1 x2)])
+                       (if (null? rest)
+                           x
+                           (loop x (car rest) (cdr rest)))))])
+      loop)
+     x1
+     x2
+     rest)]
+  [(x1) (+ x1)]
+  [() (+)])) "((result \"(case-lambda\\n  [(x1 x2) (+ x1 x2)]\\n  [(x1 x2 x3) (+ (+ x1 x2) x3)]\\n  [(x1 x2 . rest)\\n   ((letrec ([loop (lambda (x1 x2 rest)\\n                     (let ([x (+ x1 x2)])\\n                       (if (null? rest)\\n                           x\\n                           (loop x (car rest) (cdr rest)))))])\\n      loop)\\n     x1\\n     x2\\n     rest)]\\n  [(x1) (+ x1)]\\n  [() (+)])\\n\") (output . \"\"))\n")
+

elpa/geiser-20171010.1610/scheme/chibi/geiser/geiser.scm

@@ -0,0 +1,93 @@
+(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)
+  ;; (available-modules) walks the directory tree and is too slow
+  (let ((modules (map car *modules*)))
+    (map write-to-string
+         (delete-duplicates
+          (filter (lambda (module)
+                    (if (string=? "" prefix)
+                        #t
+                        (string-contains prefix (write-to-string module))))
+                  modules)))))
+
+(define (procedure-arglist id fun)
+  (let ((arglist (lambda-params (procedure-analysis fun))))
+    (if (pair? arglist)
+        (let loop ((arglist arglist)
+                   (optionals? #f)
+                   (required '())
+                   (optional '()))
+          (cond ((null? arglist)
+                 `(,id ("args" (("required" ,@(reverse required))
+                                ("optional" ,@(reverse optional))
+                                ("key")
+                                ("module" ,(let ((mod (containing-module fun))) (if mod (car mod) #f)))))))
+                ((symbol? arglist)
+                 (loop '()
+                       #t
+                       required
+                       (cons "..." (cons arglist optional))))
+                (else
+                 (loop
+                  (cdr arglist)
+                  optionals?
+                  (if optionals? required (cons (car arglist) required))
+                  (if optionals? (cons (car arglist) optional) optional)))))
+        '())))
+
+(define (geiser:operator-arglist id)
+  (let ((binding (eval id)))
+    (cond ((procedure? binding)
+           (if (opcode? binding)
+               '()
+               (procedure-arglist id binding)))
+          (else
+           '()))))
+
+(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
+         (map (lambda (id)
+                (geiser:operator-arglist id))
+              ids))))
+
+(define (geiser:no-values)
+  #f)
+
+(define (geiser:newline)
+  #f)

elpa/geiser-20171010.1610/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 ast) (chibi string) (srfi 1) (srfi 95))
+  (include "geiser.scm"))

elpa/geiser-20171010.1610/scheme/chicken/geiser/emacs.scm

@@ -0,0 +1,742 @@
+;; -*- geiser-scheme-implementation: 'chicken
+
+;; Copyright (C) 2015 Daniel J Leslie
+
+;; 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>.
+
+(module geiser
+  (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
+   geiser-chicken-use-debug-log
+   geiser-chicken-load-paths
+   geiser-chicken-symbol-match-limit)
+
+  (import chicken scheme)
+  (use
+    apropos
+    chicken-doc
+    data-structures
+    extras
+    ports
+    posix
+    srfi-1
+    srfi-13
+    srfi-14
+    srfi-18
+    srfi-69
+    tcp
+    utils)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbol lists
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-chicken-symbol-match-limit
+    (make-parameter 20))
+  
+  (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)))
+
+  (define geiser-chicken-crunch-symbols
+    (make-parameter
+     '(* + - / < <= = > >= abs acos add1 argc argv-ref arithmetic-shift asin
+	 atan atan2 bitwise-and bitwise-ior bitwise-not bitwise-xor
+	 blob->f32vector blob->f32vector/shared blob->f64vector
+	 blob->f64vector/shared blob->s16vector blob->s16vector/shared
+	 blob->s32vector blob->s32vector/shared blob->s8vector
+	 blob->s8vector/shared blob->string blob->string/shared blob->u16vector
+	 blob->u16vector/shared blob->u32vector blob->u32vector/shared
+	 blob->u8vector blob->u8vector/shared ceiling char->integer
+	 char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
+	 char-downcase char-lower-case? char-numeric? char-upcase
+	 char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>?
+	 cond-expand cos display display eq? equal? eqv? error even?
+	 exact->inexact exact? exit exp expt f32vector->blob
+	 f32vector->blob/shared f32vector-length f32vector-ref f32vector-set!
+	 f64vector->blob f64vector->blob/shared f64vector-length f64vector-ref
+	 f64vector-set! floor flush-output inexact->exact inexact?
+	 integer->char integer? log make-f32vector make-f64vector make-s16vector
+	 make-s32vector make-s8vector make-string make-u16vector make-u32vector
+	 make-u8vector max min modulo negative? newline not number->string odd?
+	 pointer-f32-ref pointer-f32-set! pointer-f64-ref pointer-f64-set!
+	 pointer-s16-ref pointer-s16-set! pointer-s32-ref pointer-s32-set!
+	 pointer-s8-ref pointer-s8-set! pointer-u16-ref pointer-u16-set!
+	 pointer-u32-ref pointer-u32-set! pointer-u8-ref pointer-u8-set!
+	 positive? quotient rec remainder round s16vector->blob
+	 s16vector->blob/shared s16vector-length s16vector-ref s16vector-set!
+	 s32vector->blob s32vector->blob/shared s32vector-length s32vector-ref
+	 s32vector-set! s8vector->blob s8vector->blob/shared s8vector-length
+	 s8vector-ref s8vector-set! sin sqrt string->blob string->blob/shared
+	 string->number 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>?
+	 sub1 subf32vector subf64vector subs16vector subs32vector subs8vector
+	 substring subu16vector subu32vector subu8vector switch tan truncate
+	 u16vector->blob u16vector->blob/shared u16vector-length u16vector-ref
+	 u16vector-set! u32vector->blob u32vector->blob/shared u32vector-length
+	 u32vector-ref u32vector-set! u8vector->blob u8vector->blob/shared
+	 u8vector-length u8vector-ref u8vector-set! unless void when write-char
+	 zero?)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Utilities
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-chicken-use-debug-log (make-parameter #f))
+
+  (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 memo (make-parameter (make-hash-table)))
+  (define (clear-memo) (hash-table-clear! (memo)))
+  (define (memoize tag thunk)
+    (let ((table (memo)))
+      (if (hash-table-exists? table tag)
+	  (begin
+	    (write-to-log '[[Cache Hit]])
+	    (hash-table-ref table tag))
+	  (fluid-let ((memoize (lambda (tag thunk) (thunk))))
+	    (write-to-log '[[Cache Miss]])
+	    (hash-table-set! table tag (thunk))
+	    
+	    (hash-table-ref table tag)))))
+  
+  (define (symbol-information-list)
+    (memoize
+     '(symbol-information-list)
+     (lambda ()
+       (map (lambda (lst)
+	      (let-values (((name module) (remove-internal-name-mangling (car lst))))
+		(append (list name module) (cdr lst))))
+	    (apropos-information-list "" #:macros? #t)))))
+
+  (define (find-symbol-information prefix)
+    (define (filter/limit pred? limit lst)
+      (cond
+       ((<= limit 0) '())
+       ((or (null? lst) (not (list? lst))) '())
+       ((pred? (car lst)) (cons (car lst) (filter/limit pred? (- limit 1) (cdr lst))))
+       (else (filter/limit pred? limit (cdr lst)))))
+    (define (find-symbol-information* prefix skipped)
+      (let ((found (filter/limit
+		    (lambda (info)
+		      (string-has-prefix? (car info) prefix))
+		    (geiser-chicken-symbol-match-limit)
+		    (symbol-information-list))))	
+	(cons found skipped)))
+    (memoize
+     `(find-symbol-information ,prefix)
+     (lambda ()
+       (find-symbol-information* (->string prefix) ""))))
+  
+  (define debug-log (make-parameter #f))
+  (define (write-to-log form)
+    (when (geiser-chicken-use-debug-log)
+      (when (not (debug-log))
+	(debug-log (file-open "geiser.log" (+ 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")))
+
+  (define (remove-internal-name-mangling sym)
+    (let* ((sym (symbol->string sym))
+	   (octothorpe-index (string-index-right sym #\#)))
+      (if octothorpe-index
+      	  (values (substring/shared sym (add1 octothorpe-index))
+      		  (substring/shared sym 0 octothorpe-index))
+      	  (values sym #f))))
+
+  (define (string-has-prefix? s prefix)
+    (cond
+     ((= 0 (string-length prefix)) #t)
+     ((= 0 (string-length s)) #f)
+     ((eq? (string-ref s 0) (string-ref prefix 0))
+      (string-has-prefix? (substring/shared s 1) (substring/shared prefix 1)))
+     (else #f)))
+  
+  ;; 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))
+
+  ;; 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
+        (cond
+         ((list? result)
+          (map (lambda (v) (with-output-to-string (lambda () (write v)))) result))
+         ((eq? result (if #f #t))
+          (list output))
+         (else
+          (list (with-output-to-string (lambda () (write result)))))))
+
+      (let ((out-form
+             `((result ,@result)
+               (output . ,output))))
+        (write out-form)
+	(write-to-log '[[RESPONSE]])
+        (write-to-log out-form))
+
+      (newline)))
+
+  (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)
+         '())
+     (if (any (cut eq? <> sym) (geiser-chicken-crunch-symbols))
+	 '(crunch)
+	 '())))
+
+  ;; 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)))))
+
+  (define (make-module-list sym module-sym prefix-exists)
+    (append
+     (if prefix-exists '(fuzzy-match) '())
+     (if (not module-sym)
+	 (find-standards-with-symbol sym)
+	 (cons module-sym (find-standards-with-symbol sym)))))
+  
+  (define (fmt node prefix)
+    (memoize
+     `(fmt ,node ,prefix)
+     (lambda ()
+       (let* ((original-entry (string->symbol (car node)))
+	      (fuzzy-entry (string->symbol (string-append prefix (car node))))
+	      (prefix-exists (not (= 0 (string-length prefix))))
+	      (module (cadr node))
+	      (module (if module (string->symbol module) #f))
+	      (rest (cddr node))
+	      (type (if (or (list? rest) (pair? rest)) (car rest) rest))
+	      (module-list (make-module-list fuzzy-entry module prefix-exists)))
+	 (cond
+	  ((equal? 'macro type)
+	   `(,fuzzy-entry ("args" (("required" <macro>)
+				   ("optional" ...)
+				   ("key")))
+			  ("module" ,@module-list)))
+	  ((or (equal? 'variable type)
+	       (equal? 'constant type))
+	   (if (not module)
+	       `(,fuzzy-entry ("value" . ,(eval original-entry)))
+	       (let* ((original-module (current-module))
+		      (desired-module (find-module module))
+		      (value (begin (switch-module desired-module)
+				    (eval original-entry))))
+		 (switch-module original-module)
+		 `(,fuzzy-entry ("value" . ,value)
+				("module" ,@module-list)))))
+	  (else
+	   (let ((reqs '())
+		 (opts '())
+		 (keys '())
+		 (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+	     (define (clean-arg arg)
+	       (let ((s (->string arg)))
+		 (string->symbol (substring/shared s 0 (add1 (string-skip-right s char-set:digit))))))
+
+	     (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)
+
+	     `(,fuzzy-entry ("args" (("required" ,@reqs)
+				     ("optional" ,@opts)
+				     ("key" ,@keys)))
+			    ("module" ,@module-list)))))))))
+
+  ;; Builds a signature list from an identifier
+  (define (find-signatures sym)
+    (memoize
+     `(find-signatures ,sym)
+     (lambda ()
+       (let ((result (find-symbol-information sym)))
+	 (map
+	  (cut fmt <> (cdr result))
+	  (car result))))))
+
+  ;; Builds the documentation from Chicken Doc for a specific symbol
+  (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))))))
+  
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Geiser core functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Basically all non-core functions pass through geiser-eval
+
+  (define (geiser-eval module form . rest)
+    (define (form-has-safe-geiser? form)
+      (any (cut eq? (car form) <>)
+	   '(geiser-no-values geiser-newline geiser-completions
+	     geiser-autodoc geiser-object-signature geiser-symbol-location
+	     geiser-symbol-documentation geiser-module-exports
+	     geiser-module-path geiser-module-location
+	     geiser-module-completions geiser-chicken-use-debug-log)))
+    
+    (define (form-has-any-geiser? form)
+      (string-has-prefix? (->string (car form)) "geiser-"))
+
+    (define (form-defines-any-module? form)
+      (or
+       ;; Geiser seems to send buffers as (begin ..buffer contents..)
+       (and (eq? (car form) 'begin)
+	    (form-defines-any-module? (cadr form)))
+       (any (cut eq? (car form) <>)
+	    '(module define-library))))
+
+    (define (module-matches-defined-module? module)
+      (any (cut eq? module <>) (list-modules)))
+    
+    (when (and module (not (symbol? module)))
+      (error "Module should be a symbol"))
+    
+    ;; All calls start at toplevel
+    (let* ((is-safe-geiser? (form-has-safe-geiser? form))
+	   (host-module (and (not is-safe-geiser?)
+			     (not (form-has-any-geiser? form))
+			     (not (form-defines-any-module? form))
+			     (module-matches-defined-module? module)
+                             module))
+	   (thunk (lambda () (eval form))))
+
+      (write-to-log `[[REQUEST host-module: ,host-module]])
+      (write-to-log form)
+
+      (if is-safe-geiser?
+	  (call-with-result #f (lambda () (memoize form thunk)))
+	  (begin
+	    (clear-memo)
+	    (call-with-result host-module thunk)))))
+
+  ;; Load a file
+
+  (define (geiser-load-file file)
+    (let* ((file (if (symbol? file) (symbol->string file) file))
+           (found-file (geiser-find-file file)))
+      (call-with-result #f
+       (lambda ()
+         (when found-file
+           (load found-file))))))
+
+  ;; The no-values identity
+
+  (define (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 prefix . rest)
+    (let* ((result (find-symbol-information prefix))
+	   (prefix (cdr result))
+	   (result-list (car result)))
+      (map
+       (cut string-append prefix <>)
+       (map car result-list))))
+
+  (define (geiser-module-completions prefix . rest)
+    (let ((prefix (->string prefix)))
+      (filter (cut string-has-prefix? <> prefix) (map ->string (list-modules)))))
+
+  (define (geiser-autodoc ids . rest)
+    (cond
+     ((null? ids) '())
+     ((not (list? ids))
+      (geiser-autodoc (list ids)))
+     ((not (symbol? (car ids)))
+      (geiser-autodoc (cdr ids)))
+     (else
+      (let ((details (find-signatures (car ids))))
+	(if (null? details)
+	    (geiser-autodoc (cdr ids))
+	    details)))))
+  
+  (define (geiser-object-signature name object . rest)
+    (let* ((sig (geiser-autodoc `(,name))))
+      (if (null? sig) '() (car sig))))
+
+    ;; TODO: Divine some way to support this functionality
+
+  (define (geiser-symbol-location symbol . rest)
+    '(("file") ("line")))
+
+  (define (geiser-symbol-documentation symbol . rest)
+    (let* ((sig (find-signatures symbol)))
+      `(("signature" ,@(car sig))
+        ("docstring" . ,(make-doc symbol)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; File and Buffer Operations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-chicken-load-paths (make-parameter '("" ".")))
+
+  (define (geiser-find-file file . rest)
+    (when file
+      (let ((paths (geiser-chicken-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 directory . rest)
+    (let* ((directory (if (symbol? directory)
+                          (symbol->string directory)
+                          directory))
+           (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory)))))
+                          (string-append directory "/")
+                          directory)))
+      (call-with-result #f
+       (lambda ()
+         (when (directory-exists? directory)
+           (geiser-chicken-load-paths (cons directory (geiser-chicken-load-paths))))))))
+
+  (define (geiser-compile-file file . rest)
+    (let* ((file (if (symbol? file) (symbol->string file) file))
+           (found-file (geiser-find-file file)))
+      (call-with-result #f
+       (lambda ()
+         (when found-file
+           (compile-file found-file))))))
+
+    ;; TODO: Support compiling regions
+
+  (define (geiser-compile 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 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)
+              ("procs" . ,proc)
+              ("syntax" . ,syn)
+              ("vars" . ,var))))))
+
+  ;; Returns the path for the file in which an egg or module was defined
+
+  (define (geiser-module-path module-name . rest)
+    #f)
+
+  ;; Returns:
+  ;; `(("file" . ,(module-path name)) ("line"))
+
+  (define (geiser-module-location name . rest)
+    #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (geiser-macroexpand form . rest)
+    (with-output-to-string
+      (lambda ()
+        (write (expand form)))))
+
+;; End module
+  )

elpa/geiser-20171010.1610/scheme/guile/geiser/completion.scm

@@ -0,0 +1,27 @@
+;;; completion.scm -- completing known symbols and module names
+
+;; Copyright (C) 2009, 2012 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Mar 02, 2009 02:22
+
+(define-module (geiser completion)
+  #:export (completions module-completions)
+  #:use-module (geiser utils)
+  #:use-module (geiser modules)
+  #:use-module (ice-9 session)
+  #:use-module (ice-9 regex))
+
+(define (completions prefix)
+  (let ((prefix (string-append "^" (regexp-quote prefix))))
+    (sort! (map symbol->string (apropos-internal prefix)) string<?)))
+
+(define (module-completions prefix)
+  (let* ((prefix (string-append "^" (regexp-quote prefix)))
+         (matcher (lambda (s) (string-match prefix s)))
+         (names (filter matcher (all-modules))))
+    (sort! names string<?)))

elpa/geiser-20171010.1610/scheme/guile/geiser/doc.scm

@@ -0,0 +1,255 @@
+;;; doc.scm -- procedures providing documentation on scheme objects
+
+;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
+
+;; 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 Feb 08, 2009 18:44
+
+(define-module (geiser doc)
+  #:export (autodoc
+            symbol-documentation
+            module-exports
+            object-signature)
+  #:use-module (geiser utils)
+  #:use-module (geiser modules)
+  #:use-module (system vm program)
+  #:use-module (ice-9 session)
+  #:use-module (ice-9 documentation)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1))
+
+(define (autodoc ids)
+  (if (not (list? ids))
+      '()
+      (map (lambda (id) (or (autodoc* id) (list id))) ids)))
+
+(define* (autodoc* id)
+  (let ((args (obj-args (symbol->object id))))
+    (and args
+         `(,@(signature id args)
+           ("module" . ,(symbol-module id))))))
+
+(define (object-signature name obj)
+  (let ((args (obj-args obj)))
+    (and args (signature name args))))
+
+(define (value-str obj)
+  (format #f "~:@y" obj))
+
+(define* (signature id args-list #:optional (detail #t))
+  (define (arglst args kind)
+    (let ((args (assq-ref args kind)))
+      (cond ((or (not args) (null? args)) '())
+            ((list? args) args)
+            (else (list args)))))
+  (define (mkargs as)
+    `(("required" ,@(arglst as 'required))
+      ("optional" ,@(arglst as 'optional)
+       ,@(if (assq-ref as 'rest) (list "...") '()))
+      ("key" ,@(arglst as 'keyword))))
+  (let* ((args-list (map mkargs (if (list? args-list) args-list '())))
+         (value (and (and detail (null? args-list))
+                     (value-str (symbol->object id)))))
+    `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '()))))
+
+(define default-macro-args '(((required ...))))
+
+(define geiser-args-key (gensym "geiser-args-key-"))
+
+(define (obj-args obj)
+  (cond ((not obj) #f)
+        ((or (procedure? obj) (program? obj))
+         (cond ((procedure-property obj geiser-args-key))
+               ((arguments obj) =>
+                (lambda (args)
+                  (set-procedure-property! obj geiser-args-key args)
+                  args))
+               (else #f)))
+        ((and (macro? obj) (macro-transformer obj)) => macro-args)
+        ((macro? obj) default-macro-args)
+        (else 'variable)))
+
+(define (arguments proc)
+  (define (p-args prog)
+    (let ((as (map (lambda (a)
+                     ((@@ (system vm program) arity->arguments-alist) prog a))
+                     (or (program-arities prog) '()))))
+      (and (not (null? as)) as)))
+  (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y)))))
+  (cond ((is-a? proc <generic>) (generic-args proc))
+        ((doc->args proc) => list)
+        ((procedure-property proc 'arglist) => (clist arglist->args))
+        ((procedure-source proc) => (clist source->args))
+        ((and (program? proc) (p-args proc)))
+        ((procedure-property proc 'arity) => (clist arity->args))
+        (else #f)))
+
+(define (source->args src)
+  (let ((formals (cadr src)))
+    (cond ((list? formals) `((required . ,formals)))
+          ((pair? formals)
+           `((required . ,(car formals)) (rest . ,(cdr formals))))
+          (else #f))))
+
+(define (macro-args tf)
+  (define* (collect args #:optional (req '()))
+    (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f)))
+          ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args)))
+          ((and (pair? args) (symbol? (car args)))
+           (collect (cdr args) (cons (car args) req)))
+          (else #f)))
+  (let* ((pats (procedure-property tf 'patterns))
+         (args (and pats (filter-map collect pats))))
+    (or (and args (not (null? args)) args) default-macro-args)))
+
+(define (arity->args art)
+  (define (gen-arg-names count)
+    (map (lambda (x) '_) (iota (max count 0))))
+  (let ((req (car art))
+        (opt (cadr art))
+        (rest (caddr art)))
+    `(,@(if (> req 0)
+            (list (cons 'required (gen-arg-names req)))
+            '())
+      ,@(if (> opt 0)
+            (list (cons 'optional (gen-arg-names opt)))
+            '())
+      ,@(if rest (list (cons 'rest 'rest)) '()))))
+
+(define (arglist->args arglist)
+  `((required . ,(car arglist))
+    (optional . ,(cadr arglist))
+    (keyword . ,(caddr arglist))
+    (rest . ,(car (cddddr arglist)))))
+
+(define (doc->args proc)
+  ;; Guile 2.0.9+ uses the (texinfo ...) modules to produce
+  ;; `guile-procedures.txt', and the output has a single hyphen, whereas
+  ;; `makeinfo' produces two hyphens.
+  (define proc-rx "--? Scheme Procedure: ([^[\n]+)\n")
+  (define proc-rx2 "--? Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)")
+  (let ((doc (object-documentation proc)))
+    (and doc
+         (let ((match (or (string-match proc-rx doc)
+                          (string-match proc-rx2 doc))))
+           (and match
+                (parse-signature-string (match:substring match 1)))))))
+
+(define (parse-signature-string str)
+  (define opt-arg-rx "\\[([^] ]+)\\]?")
+  (define opt-arg-rx2 "([^ ])+\\]+")
+  (let ((tokens (string-tokenize str)))
+    (if (< (length tokens) 2)
+        '()
+        (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f))
+          (cond ((null? tokens)
+                 `((required ,@(map string->symbol (reverse! req)))
+                   (optional ,@(map string->symbol (reverse! opt)))
+                   ,@(if rest
+                         (list (cons 'rest (string->symbol rest)))
+                         '())))
+                ((string=? "." (car tokens))
+                 (if (not (null? (cdr tokens)))
+                     (loop (cddr tokens) req opt (cadr tokens))
+                     (loop '() req opt "rest")))
+                ((or (string-match opt-arg-rx (car tokens))
+                     (string-match opt-arg-rx2 (car tokens)))
+                 => (lambda (m)
+                      (loop (cdr tokens)
+                            req
+                            (cons (match:substring m 1) opt)
+                            rest)))
+                (else (loop (cdr tokens)
+                            (cons (car tokens) req)
+                            opt
+                            rest)))))))
+
+(define (generic-args gen)
+  (define (src> src1 src2)
+    (> (length (cadr src1)) (length (cadr src2))))
+  (define (src m)
+    (catch #t
+      (lambda () (method-source m))
+      (lambda (k . a) #f)))
+  (let* ((methods (generic-function-methods gen))
+         (srcs (filter identity (map src methods))))
+    (cond ((and (null? srcs)
+                (not (null? methods))
+                (method-procedure (car methods))) => arguments)
+          ((not (null? srcs)) (list (source->args (car (sort! srcs src>)))))
+          (else '(((rest . rest)))))))
+
+(define (symbol-documentation sym)
+  (let ((obj (symbol->object sym)))
+    (if obj
+        `(("signature" . ,(or (obj-signature sym obj #f) sym))
+          ("docstring" . ,(docstring sym obj))))))
+
+(define (docstring sym obj)
+  (define (valuable?)
+    (not (or (macro? obj) (procedure? obj) (program? obj))))
+  (with-output-to-string
+    (lambda ()
+      (let* ((type (cond ((macro? obj) "A macro")
+                         ((procedure? obj) "A procedure")
+                         ((program? obj) "A compiled program")
+                         (else "An object")))
+             (modname (symbol-module sym))
+             (doc (object-documentation obj)))
+        (display type)
+        (if modname
+            (begin
+              (display " in module ")
+              (display modname)
+              (display ".")))
+        (newline)
+        (if doc (begin (newline) (display doc)))
+        (if (valuable?) (begin (newline)
+                               (display "Value:")
+                               (newline)
+                               (display "   ")
+                               (display (value-str obj))))))))
+
+(define* (obj-signature sym obj #:optional (detail #t))
+  (let ((args (obj-args obj)))
+    (and args (signature sym args detail))))
+
+(define (module-exports mod-name)
+  (define elt-sort (make-symbol-sort car))
+  (let* ((mod (catch #t
+                (lambda () (resolve-interface mod-name))
+                (lambda args (resolve-module mod-name))))
+         (elts (hash-fold classify-module-object
+                          (list '() '() '())
+                          (module-obarray mod)))
+         (elts (map elt-sort elts))
+         (subs (map (lambda (m) (list (module-name m)))
+                    (submodules (resolve-module mod-name #f)))))
+    (list (cons "modules" subs)
+          (cons "procs" (car elts))
+          (cons "syntax" (cadr elts))
+          (cons "vars" (caddr elts)))))
+
+(define (classify-module-object name var elts)
+  (let ((obj (and (variable-bound? var)
+                  (variable-ref var))))
+    (cond ((or (not obj) (module? obj)) elts)
+          ((or (procedure? obj) (program? obj))
+           (list (cons (list name `("signature" . ,(obj-signature name obj)))
+                       (car elts))
+                 (cadr elts)
+                 (caddr elts)))
+          ((macro? obj)
+           (list (car elts)
+                 (cons (list name `("signature" . ,(obj-signature name obj)))
+                       (cadr elts))
+                 (caddr elts)))
+          (else (list (car elts)
+                      (cadr elts)
+                      (cons (list name) (caddr elts)))))))

elpa/geiser-20171010.1610/scheme/guile/geiser/emacs.scm

@@ -0,0 +1,58 @@
+;;; emacs.scm -- procedures for emacs interaction: entry point
+
+;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
+
+;; 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 Feb 08, 2009 18:39
+
+(define-module (geiser emacs)
+  #:use-module (ice-9 match)
+  #:use-module (system repl command)
+  #:use-module (system repl error-handling)
+  #:use-module (system repl server)
+  #:use-module (geiser evaluation)
+  #:use-module ((geiser modules) #:renamer (symbol-prefix-proc 'ge:))
+  #:use-module ((geiser completion) #:renamer (symbol-prefix-proc 'ge:))
+  #:use-module ((geiser xref) #:renamer (symbol-prefix-proc 'ge:))
+  #:use-module ((geiser doc) #:renamer (symbol-prefix-proc 'ge:)))
+
+(define this-module (resolve-module '(geiser emacs)))
+
+(define-meta-command ((geiser-no-values geiser) repl)
+  "geiser-no-values
+No-op command used internally by Geiser."
+  (values))
+
+(define-meta-command ((geiser-newline geiser) repl)
+  "geiser-newline
+Meta-command used by Geiser to emit a new line."
+  (newline))
+
+(define-meta-command ((geiser-eval geiser) repl (mod form args) . rest)
+  "geiser-eval module form args ()
+Meta-command used by Geiser to evaluate and compile code."
+  (if (null? args)
+      (call-with-error-handling
+       (lambda () (ge:compile form mod)))
+      (let ((proc (eval form this-module)))
+        (ge:eval `(,proc ,@args) mod))))
+
+(define-meta-command ((geiser-load-file geiser) repl file)
+  "geiser-load-file file
+Meta-command used by Geiser to load and compile files."
+  (call-with-error-handling
+   (lambda () (ge:compile-file file))))
+
+
+(define-meta-command ((geiser-start-server geiser) repl)
+  "geiser-start-server
+Meta-command used by Geiser to start a REPL server."
+  (let* ((sock (make-tcp-server-socket #:port 0))
+         (port (sockaddr:port (getsockname sock))))
+    (spawn-server sock)
+    (write (list 'port port))
+    (newline)))

elpa/geiser-20171010.1610/scheme/guile/geiser/evaluation.scm

@@ -0,0 +1,144 @@
+;;; evaluation.scm -- evaluation, compilation and macro-expansion
+
+;; Copyright (C) 2009, 2010, 2011, 2013, 2015 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Mar 02, 2009 02:46
+
+(cond-expand
+  (guile-2.2
+   (define-module (geiser evaluation)
+     #:export (ge:compile
+               ge:eval
+               ge:macroexpand
+               ge:compile-file
+               ge:load-file
+               ge:set-warnings
+               ge:add-to-load-path)
+     #:use-module (geiser modules)
+     #:use-module (srfi srfi-1)
+     #:use-module (language tree-il)
+     #:use-module (system base compile)
+     #:use-module (system base message)
+     #:use-module (system base pmatch)
+     #:use-module (system vm program)
+     #:use-module (ice-9 pretty-print)
+     #:use-module (system vm loader)))
+  (else
+   (define-module (geiser evaluation)
+     #:export (ge:compile
+               ge:eval
+               ge:macroexpand
+               ge:compile-file
+               ge:load-file
+               ge:set-warnings
+               ge:add-to-load-path)
+     #:use-module (geiser modules)
+     #:use-module (srfi srfi-1)
+     #:use-module (language tree-il)
+     #:use-module (system base compile)
+     #:use-module (system base message)
+     #:use-module (system base pmatch)
+     #:use-module (system vm program)
+     #:use-module (ice-9 pretty-print))))
+
+
+(define compile-opts '())
+(define compile-file-opts '())
+
+(define default-warnings '(arity-mismatch unbound-variable format))
+(define verbose-warnings `(unused-variable ,@default-warnings))
+
+(define (ge:set-warnings wl)
+  (let* ((warns (cond ((list? wl) wl)
+                      ((symbol? wl) (case wl
+                                      ((none nil null) '())
+                                      ((medium default) default-warnings)
+                                      ((high verbose) verbose-warnings)
+                                      (else '())))
+                      (else '())))
+         (fwarns (if (memq 'unused-variable warns)
+                     (cons 'unused-toplevel warns)
+                     warns)))
+    (set! compile-opts (list #:warnings warns))
+    (set! compile-file-opts (list #:warnings fwarns))))
+
+(ge:set-warnings 'none)
+
+(define (call-with-result thunk)
+  (letrec* ((result #f)
+            (output
+             (with-output-to-string
+               (lambda ()
+                 (with-fluids ((*current-warning-port* (current-output-port))
+                               (*current-warning-prefix* ""))
+                   (with-error-to-port (current-output-port)
+                     (lambda () (set! result
+                                  (map object->string (thunk))))))))))
+    (write `((result ,@result) (output . ,output)))
+    (newline)))
+
+(define (ge:compile form module)
+  (compile* form module compile-opts))
+
+(define (compile* form module-name opts)
+  (let* ((module (or (find-module module-name) (current-module)))
+         (ev (lambda ()
+               (call-with-values
+                   (lambda ()
+                     (let* ((to (cond-expand (guile-2.2 'bytecode)
+                                             (else 'objcode)))
+                            (cf (cond-expand (guile-2.2 load-thunk-from-memory)
+                                             (else make-program)))
+                            (o (compile form
+                                        #:to to
+                                        #:env module
+                                        #:opts opts))
+                            (thunk (cf o)))
+                       (start-stack 'geiser-evaluation-stack
+                                    (eval `(,thunk) module))))
+                 (lambda vs vs)))))
+    (call-with-result ev)))
+
+(define (ge:eval form module-name)
+  (let* ((module (or (find-module module-name) (current-module)))
+         (ev (lambda ()
+               (call-with-values
+                   (lambda () (eval form module))
+                 (lambda vs vs)))))
+    (call-with-result ev)))
+
+(define (ge:compile-file path)
+  (call-with-result
+   (lambda ()
+     (let ((cr (compile-file path
+                             #:canonicalization 'absolute
+                             #:opts compile-file-opts)))
+       (and cr
+            (list (object->string (save-module-excursion
+                                   (lambda () (load-compiled cr))))))))))
+
+(define ge:load-file ge:compile-file)
+
+(define (ge:macroexpand form . all)
+  (let ((all (and (not (null? all)) (car all))))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (tree-il->scheme (macroexpand form)))))))
+
+(define (add-to-list lst dir)
+  (and (not (member dir lst))))
+
+(define (ge:add-to-load-path dir)
+  (and (file-is-directory? dir)
+       (let ((in-lp (member dir %load-path))
+             (in-clp (member dir %load-compiled-path)))
+         (when (not in-lp)
+           (set! %load-path (cons dir %load-path)))
+         (when (not in-clp)
+           (set! %load-compiled-path (cons dir %load-compiled-path)))
+         (or in-lp in-clp))))

elpa/geiser-20171010.1610/scheme/guile/geiser/modules.scm

@@ -0,0 +1,77 @@
+;;; modules.scm -- module metadata
+
+;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Mar 02, 2009 02:00
+
+(define-module (geiser modules)
+  #:export (symbol-module
+            module-name?
+            module-path
+            find-module
+            all-modules
+            submodules
+            module-location)
+  #:use-module (geiser utils)
+  #:use-module (system vm program)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 session)
+  #:use-module (srfi srfi-1))
+
+(define (module-name? module-name)
+  (and (list? module-name)
+       (not (null? module-name))
+       (every symbol? module-name)))
+
+(define (symbol-module sym . all)
+  (and sym
+       (catch 'module-name
+         (lambda ()
+           (apropos-fold (lambda (module name var init)
+                           (if (eq? name sym)
+                               (throw 'module-name (module-name module))
+                               init))
+                         #f
+                         (regexp-quote (symbol->string sym))
+                         (if (or (null? all) (not (car all)))
+                             (apropos-fold-accessible (current-module))
+                             apropos-fold-all)))
+         (lambda (key . args)
+           (and (eq? key 'module-name) (car args))))))
+
+(define (module-location name)
+  (make-location (module-path name) #f))
+
+(define (find-module mod-name)
+  (and (module-name? mod-name)
+       (resolve-module mod-name #f #:ensure #f)))
+
+(define (module-path module-name)
+  (and (module-name? module-name)
+       (or ((@@ (ice-9 session) module-filename) module-name)
+           (module-filename (resolve-module module-name #f)))))
+
+(define (submodules mod)
+  (hash-map->list (lambda (k v) v) (module-submodules mod)))
+
+(define (root-modules)
+  (submodules (resolve-module '() #f)))
+
+(define (all-modules)
+  (define (maybe-name m)
+    (and (module-kind m) (format #f "~A" (module-name m))))
+  (let* ((guile (resolve-module '(guile)))
+         (roots (remove (lambda (m) (eq? m guile)) (root-modules)))
+         (children (append-map all-child-modules roots)))
+    (cons "(guile)" (filter-map maybe-name children))))
+
+(define* (all-child-modules mod #:optional (seen '()))
+  (let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod))))
+    (fold (lambda (m all) (append (all-child-modules m all) all))
+          (list mod)
+          cs)))

elpa/geiser-20171010.1610/scheme/guile/geiser/utils.scm

@@ -0,0 +1,52 @@
+;;; utils.scm -- utility functions
+
+;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Mar 02, 2009 01:48
+
+(define-module (geiser utils)
+  #:export (make-location
+            symbol->object
+            pair->list
+            sort-symbols!
+            make-symbol-sort
+            gensym?)
+  #:use-module (ice-9 regex))
+
+(define (symbol->object sym)
+  (and (symbol? sym)
+       (module-defined? (current-module) sym)
+       (module-ref (current-module) sym)))
+
+(define (pair->list pair)
+  (let loop ((d pair) (s '()))
+    (cond ((null? d) (reverse! s))
+          ((symbol? d) (reverse! (cons d s)))
+          (else (loop (cdr d) (cons (car d) s))))))
+
+(define (make-location file line)
+  (list (cons "file" (if (string? file) file '()))
+        (cons "line" (if (number? line) (+ 1 line) '()))))
+
+(define (sort-symbols! syms)
+  (let ((cmp (lambda (l r)
+               (string<? (symbol->string l) (symbol->string r)))))
+    (sort! syms cmp)))
+
+(define (make-symbol-sort sel)
+  (let ((cmp (lambda (a b)
+               (string<? (symbol->string (sel a))
+                         (symbol->string (sel b))))))
+    (lambda (syms)
+      (sort! syms cmp))))
+
+(define (gensym? sym)
+  (and (symbol? sym) (gensym-name? (format #f "~A" sym))))
+
+(define (gensym-name? name)
+  (and (string-match "^#[{]" name) #t))

elpa/geiser-20171010.1610/scheme/guile/geiser/xref.scm

@@ -0,0 +1,84 @@
+;;; xref.scm -- cross-referencing utilities
+
+;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
+
+;; 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: Mon Mar 02, 2009 02:37
+
+(define-module (geiser xref)
+  #:export (symbol-location
+            generic-methods
+            callers
+            callees
+            find-file)
+  #:use-module (geiser utils)
+  #:use-module (geiser modules)
+  #:use-module (geiser doc)
+  #:use-module (oop goops)
+  #:use-module (system xref)
+  #:use-module (system vm program))
+
+(define (symbol-location sym)
+  (cond ((symbol-module sym) => module-location)
+        (else (let ((obj (symbol->object sym)))
+                (or (and (program? obj) (program-location obj))
+                    '())))))
+
+(define (generic-methods sym)
+  (let* ((gen (symbol->object sym))
+         (methods (if (is-a? gen <generic>)
+                      (generic-function-methods gen)
+                      '())))
+    (filter (lambda (x) (not (null? x)))
+            (map (lambda (m)
+                   (make-xref (method-procedure m) sym (symbol-module sym)))
+                 methods))))
+
+(define (make-xref proc name module)
+  (and proc
+       `(("location" . ,(or (program-location proc) (symbol-location name)))
+         ("signature" . ,(object-signature name proc))
+         ("module" . ,(or module '())))))
+
+(define (program-location p)
+  (cond ((not (program? p)) #f)
+        ((program-source p 0) =>
+         (lambda (s) (make-location (program-path p) (source:line s))))
+        ((program-path p) => (lambda (s) (make-location s #f)))
+        (else #f)))
+
+(define (program-path p)
+  (let* ((mod (program-module p))
+         (name (and (module? mod) (module-name mod))))
+    (and name (module-path name))))
+
+(define (procedure-xref proc . mod-name)
+  (let* ((proc-name (or (procedure-name proc) '<anonymous>))
+         (mod-name (if (null? mod-name)
+                       (symbol-module proc-name)
+                       (car mod-name))))
+    (make-xref proc proc-name mod-name)))
+
+(define (callers sym)
+  (let ((mod (symbol-module sym #t)))
+    (and mod
+         (apply append (map (lambda (procs)
+                              (map (lambda (proc)
+                                     (procedure-xref proc (car procs)))
+                                   (cdr procs)))
+                            (procedure-callers (cons mod sym)))))))
+
+(define (callees sym)
+  (let ((obj (symbol->object sym)))
+    (and obj
+         (map procedure-xref (procedure-callees obj)))))
+
+(define (find-file path)
+  (let loop ((dirs %load-path))
+    (if (null? dirs) #f
+        (let ((candidate (string-append (car dirs) "/" path)))
+          (if (file-exists? candidate) candidate (loop (cdr dirs)))))))

elpa/geiser-20171010.1610/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)))

elpa/geiser-20171010.1610/scheme/mit/geiser/emacs.scm

@@ -0,0 +1,281 @@
+;;;; 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)
+       ;; was string-prefix?, now defaults to case-insensitive
+       ;; (MIT/GNU Scheme's default)
+       (if (and (string-prefix-ci? prefix (symbol-name symbol))
+                (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))))

elpa/geiser-20171010.1610/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))

elpa/geiser-20171010.1610/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))
+

elpa/geiser-20171010.1610/scheme/racket/geiser/autodoc.rkt

@@ -0,0 +1,315 @@
+;;; autodoc.rkt -- suport for autodoc echo
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Jose Antonio Ortega Ruiz
+
+;; 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 May 03, 2009 14:45
+
+#lang racket
+
+(provide autodoc
+         symbol-documentation
+         module-exports
+         update-signature-cache
+         preload-help
+         get-help)
+
+(require racket/help
+         geiser/utils
+         geiser/modules
+         geiser/locations)
+
+(define loader-thread #f)
+
+(define (preload-help)
+  (set! loader-thread
+        (thread (lambda ()
+                  (with-output-to-string (lambda ()
+                                           (help meh-i-dont-exist)))))))
+
+(define here (current-namespace))
+
+(define (get-help symbol mod)
+  (when loader-thread
+    (thread-wait loader-thread)
+    (set! loader-thread #f))
+  (if (eq? symbol mod)
+      (get-mod-help mod)
+      (with-handlers ([exn? (lambda (_) (eval `(help ,symbol) here))])
+        (eval `(help ,symbol #:from ,(ensure-module-spec mod)) here))))
+
+(define (get-mod-help mod)
+  (let-values ([(ids syns) (module-identifiers mod)])
+    (let ([sym (cond [(not (null? syns)) (car syns)]
+                     [(not (null? ids)) (car ids)]
+                     [else #f])])
+      (and sym (get-help sym mod)))))
+
+(define (symbol-documentation sym)
+  (let* ([val (value sym (symbol-module sym))]
+         [sign (autodoc* sym)])
+    (and sign
+         (list (cons "signature" (autodoc* sym #f))
+               (cons "docstring" (docstring sym val sign))))))
+
+(define (docstring sym val sign)
+  (let* ([mod (assoc "module" (cdr sign))]
+         [mod (if mod (cdr mod) "<unknown>")]
+         [id (namespace-symbol->identifier sym)]
+         [desc (if (identifier? id) (format "~%~%~a" (describe id sym)) "")])
+    (if val
+        (format "A ~a in module ~a.~a~a~a"
+                (if (procedure? val) "procedure" "variable")
+                mod
+                (if (procedure? val)
+                    ""
+                    (format "~%~%Value:~%~%  ~a" val))
+                (if (has-contract? val)
+                    (format "~%~%Contract:~%~%  ~a"
+                            (contract-name (value-contract val)))
+                    "")
+                desc)
+        (format "An identifier in module ~a.~a" mod desc))))
+
+;; Lifted from Eli's interactive.rkt
+(define (describe id s)
+  (define b (identifier-binding id))
+  (cond
+   [(not b) (format "`~s' is a toplevel (or unbound) identifier." s)]
+   [(eq? b 'lexical) (format "`~s' is a lexical identifier." s)]
+   [(or (not (list? b)) (not (= 7 (length b))))
+    "*** internal error, racket changed ***"]
+   [else
+    (let-values ([(source-mod source-id
+                   nominal-source-mod nominal-source-id
+                   source-phase import-phase
+                   nominal-export-phase)
+                  (apply values b)])
+      (let ([aliased (not (eq? s source-id))]
+            [for-syn (eqv? source-phase 1)]
+            [amod (not (equal? source-mod nominal-source-mod))]
+            [aid (not (eq? s nominal-source-id))])
+        (if (or aliased for-syn amod aid)
+            (string-append
+             "Defined"
+             (if for-syn " for syntax" "")
+             (if aliased (format " as `~s' " source-id) "")
+             (if amod
+                 (format " in module ~a\nand required~a in module ~a"
+                         (module-path-index->name source-mod)
+                         (if (eqv? import-phase 1) "-for-syntax" "")
+                         (module-path-index->name nominal-source-mod))
+                 "")
+             (if aid
+                 (format ",\nwhere it is defined as `~s'" nominal-source-id)
+                 "")
+             ".")
+            "")))]))
+
+(define (value id mod)
+  (with-handlers ([exn? (const #f)])
+    (dynamic-require mod id (const #f))))
+
+(define (autodoc ids)
+  (map (lambda (id) (or (autodoc* id) (list id)))
+       (if (list? ids) ids '())))
+
+(define (autodoc* id (extra #t))
+  (define (val)
+    (with-handlers ([exn? (const "")])
+      (parameterize ([error-print-width 60])
+        (format "~.a" (namespace-variable-value id)))))
+  (and
+   (symbol? id)
+   (let* ([loc (symbol-location* id)]
+          [name (car loc)]
+          [path (cdr loc)]
+          [sgns (and path (find-signatures path name id))]
+          [value (if (and extra sgns (not (list? sgns)))
+                     (list (cons "value" (val)))
+                     '())]
+          [mod (if (and extra sgns path)
+                   (list (cons "module"
+                               (module-path-name->name path)))
+                   '())])
+     (and sgns
+          `(,id
+            ("name" . ,name)
+            ("args" ,@(if (list? sgns) (map format-signature sgns) '()))
+            ,@value
+            ,@mod)))))
+
+(define (format-signature sign)
+  (if (signature? sign)
+      `(("required" ,@(signature-required sign))
+        ("optional" ,@(signature-optional sign)
+         ,@(let ((rest (signature-rest sign)))
+             (if rest (list "...") '())))
+        ("key" ,@(signature-keys sign)))
+      '()))
+
+(define signatures (make-hash))
+
+(struct signature (required optional keys rest))
+
+(define (find-signatures path name local-name)
+  (let ([path (if (path? path) (path->string path) path)])
+    (hash-ref! (hash-ref! signatures
+                          path
+                          (lambda () (parse-signatures path)))
+               name
+               (lambda () (infer-signatures local-name)))))
+
+(define (parse-signatures path)
+  (let ([result (make-hasheq)])
+    (with-handlers ([exn? (lambda (e) result)])
+      (with-input-from-file path
+        (lambda ()
+          (parameterize ([read-accept-reader #t])
+            (let loop ([stx (read-syntax path)])
+              (cond [(eof-object? stx) void]
+                    [(syntax->datum stx) =>
+                     (lambda (datum)
+                       (parse-datum! datum result)
+                       (loop (read-syntax path)))]
+                    [else void]))))))
+    result))
+
+(define (parse-datum! datum store)
+  (with-handlers ([exn? (lambda (_) void)])
+    (match datum
+      [`(module ,name ,lang (#%module-begin . ,forms))
+       (for-each (lambda (f) (parse-datum! f store)) forms)]
+      [`(module ,name ,lang . ,forms)
+       (for-each (lambda (f) (parse-datum! f store)) forms)]
+      [`(define ((,name . ,formals) . ,_) . ,_)
+       (add-signature! name formals store)]
+      [`(define (,name . ,formals) . ,_)
+       (add-signature! name formals store)]
+      [`(define ,name (lambda ,formals . ,_))
+       (add-signature! name formals store)]
+      [`(define ,name (case-lambda ,clauses ...))
+       (for-each (lambda (c) (add-signature! name (car c) store))
+                 (reverse clauses))]
+      [`(,(or 'struct 'define-struct) ,name ,(? symbol? _)
+         ,(list formals ...) . ,_)
+       (add-signature! name formals store)]
+      [`(,(or 'struct 'define-struct) ,name ,(list formals ...) . ,_)
+       (add-signature! name formals store)]
+      [`(define-for-syntax (,name . ,formals) . ,_)
+       (add-signature! name formals store)]
+      [`(define-for-syntax ,name (lambda ,formals . ,_))
+       (add-signature! name formals store)]
+      [`(define-syntax-rule (,name . ,formals) . ,_)
+       (add-signature! name formals store)]
+      [`(define-syntax ,name (syntax-rules ,specials . ,clauses))
+       (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
+                 (reverse clauses))]
+      [`(define-syntax ,name (lambda ,_ (syntax-case ,_ . ,clauses)))
+       (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
+                 (reverse clauses))]
+      [`(define-type ,_ . ,cases)
+       (for-each (lambda (c) (add-signature! (car c) (cdr c) store)) cases)]
+      [_ void])))
+
+(define (add-signature! name formals store)
+  (when (symbol? name)
+    (hash-set! store
+               name
+               (cons (parse-formals formals)
+                     (hash-ref store name '())))))
+
+(define (add-syntax-signature! name formals store)
+  (when (symbol? name)
+    (hash-set! store
+               name
+               (cons (signature formals '() '() #f)
+                     (hash-ref store name '())))))
+
+(define (parse-formals formals)
+  (let loop ([formals formals] [req '()] [opt '()] [keys '()])
+    (cond [(null? formals)
+           (signature (reverse req) (reverse opt) (reverse keys) #f)]
+          [(symbol? formals)
+           (signature (reverse req) (reverse opt) (reverse keys) formals)]
+          [(pair? (car formals)) (loop (cdr formals)
+                                       req
+                                       (cons (car formals) opt)
+                                       keys)]
+          [(keyword? (car formals)) (let* ((kname (car formals))
+                                           (arg-id (cadr formals))
+                                           (name (if (pair? arg-id)
+                                                     (list kname
+                                                           (cadr arg-id))
+                                                     (list kname))))
+                                      (loop (cddr formals)
+                                            req
+                                            opt
+                                            (cons name keys)))]
+          [else (loop (cdr formals) (cons (car formals) req) opt keys)])))
+
+(define (infer-signatures name)
+  (with-handlers ([exn:fail:syntax? (const `(,(signature '(...) '() '() #f)))]
+                  [exn:fail:contract:variable? (const #f)])
+    (let ([v (namespace-variable-value name)])
+      (if (procedure? v)
+          (arity->signatures (procedure-arity v))
+          'variable))))
+
+(define (arity->signatures arity)
+  (define (args count) (build-list count (const '_)))
+  (define (arity->signature arity)
+    (cond [(number? arity)
+           (signature (args arity) '() '() #f)]
+          [(arity-at-least? arity)
+           (signature (args (arity-at-least-value arity)) '() '() 'rest)]))
+  (define (conseq? lst)
+    (cond [(< (length lst) 2) (number? (car lst))]
+          [(and (number? (car lst))
+                (number? (cadr lst))
+                (eqv? (+ 1 (car lst)) (cadr lst)))
+           (conseq? (cdr lst))]
+          [else #f]))
+  (cond [(and (list? arity) (conseq? arity))
+         (let ((mi (apply min arity))
+               (ma (apply max arity)))
+           (list (signature (args mi) (args (- ma mi)) '() #f)))]
+        [(list? arity) (map arity->signature arity)]
+        [else (list (arity->signature arity))]))
+
+(define (update-signature-cache path (form #f))
+  (when (and (string? path)
+             (or (not form)
+                 (and (list? form)
+                      (not (null? form))
+                      (memq (car form)
+                            '(define-syntax-rule struct
+                               define-syntax define set! define-struct)))))
+    (hash-remove! signatures path)))
+
+(define (module-exports mod)
+  (define (contracted id)
+    (let ([v (value id mod)])
+      (if (has-contract? v)
+          (list id (cons "info" (contract-name (value-contract v))))
+          (entry id))))
+  (define (entry id)
+    (let ((sign (eval `(,autodoc* ',id #f)
+                      (module-spec->namespace mod #f #f))))
+      (if sign (list id (cons "signature" sign)) (list id))))
+  (define (classify-ids ids)
+    (let loop ([ids ids] [procs '()] [vars '()])
+      (cond [(null? ids)
+             `(("procs" ,@(map entry (reverse procs)))
+               ("vars" ,@(map list (reverse vars))))]
+            [(procedure? (value (car ids) mod))
+             (loop (cdr ids) (cons (car ids) procs) vars)]
+            [else (loop (cdr ids) procs (cons (car ids) vars))])))
+  (let-values ([(ids syn) (module-identifiers mod)])
+    `(,@(classify-ids ids)
+      ("syntax" ,@(map contracted syn))
+      ("modules" ,@(map list (or (submodules mod) '()))))))

elpa/geiser-20171010.1610/scheme/racket/geiser/completions.rkt

@@ -0,0 +1,29 @@
+;;; completions.rkt -- completion support
+
+;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
+
+;; 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 Apr 26, 2009 19:02
+
+#lang racket
+
+(provide symbol-completions
+         module-completions)
+
+(require srfi/13 geiser/utils geiser/modules)
+
+(define (filter-prefix prefix lst sort?)
+  (filter (lambda (s) (string-prefix? prefix s))
+          (if sort? (sort lst string<?) lst)))
+
+(define (symbol-completions prefix)
+  (filter-prefix prefix
+                 (map symbol->string (namespace-mapped-symbols))
+                 #t))
+
+(define (module-completions prefix)
+  (filter-prefix prefix (module-list) #f))

elpa/geiser-20171010.1610/scheme/racket/geiser/enter.rkt

@@ -0,0 +1,155 @@
+;;; enter.rkt -- custom module loaders
+
+;; Copyright (C) 2010, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
+
+;; 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: Wed Mar 31, 2010 21:53
+
+#lang racket/base
+
+(require syntax/modcode
+         (for-syntax racket/base)
+         racket/path)
+
+(provide get-namespace visit-module module-loader)
+
+(struct mod (name load-path timestamp depends) #:transparent)
+
+(define (make-mod name path ts code)
+  (let ([deps (if code
+                  (apply append (map cdr (module-compiled-imports code)))
+                  null)])
+    (mod name (path->string path) ts deps)))
+
+(define loaded (make-hash))
+
+(define (mod->path mod)
+  (with-handlers ([exn? (lambda (_) #f)])
+    (let ([rp (module-path-index-resolve (module-path-index-join mod #f))])
+      (resolved-module-path-name rp))))
+
+(define (visit-module mod)
+  (dynamic-require mod #f)
+  (check-latest mod))
+
+(define (module-loader orig)
+  (make-loader orig #f))
+
+(define inhibit-eval (make-parameter #f))
+
+(define (get-namespace mod)
+  (let ([mod (cond [(symbol? mod) mod]
+                   [(string? mod) (find-module! (string->path mod) mod)]
+                   [(path? mod) (find-module! mod (path->string mod))]
+                   [else mod])])
+    (and mod
+         (with-handlers ([exn? (lambda (_) #f)])
+           (parameterize ([inhibit-eval #t])
+             (module->namespace mod))))))
+
+(define (find-module! path path-str)
+  (let ([m (or (hash-ref loaded path #f)
+               (let loop ([ps (remove path (resolve-paths path))]
+                          [seen '()])
+                 (cond [(null? ps) #f]
+                       [(hash-ref loaded (car ps) #f) =>
+                        (lambda (m)
+                          (add-paths! m (cdr ps))
+                          (add-paths! m (cons path seen))
+                          m)]
+                       [else (loop (cdr ps) (cons (car ps) seen))])))])
+    (list 'file (or (and m (mod-load-path m)) path-str))))
+
+(define (add-paths! m ps)
+  (for-each (lambda (p) (hash-set! loaded p m)) ps))
+
+(define (resolve-paths path)
+  (define (find root rest)
+    (let* ([alt-root (resolve-path root)]
+           [same? (equal? root alt-root)])
+      (cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
+            [else (let* ([c (car rest)]
+                         [cs (cdr rest)]
+                         [rps (find (build-path root c) cs)])
+                    (if same?
+                        rps
+                        (append rps (find (build-path alt-root c) cs))))])))
+  (let ([cmps (explode-path path)])
+    (find (car cmps) (cdr cmps))))
+
+(define (notify re? path)
+  (when re? (fprintf (current-error-port) " [re-loading ~a]\n" path)))
+
+(define (module-name? name)
+  (and name (not (and (pair? name) (not (car name))))))
+
+(define (module-code re? name path)
+  (get-module-code path
+                   "compiled"
+                   (lambda (e)
+                     (parameterize ([compile-enforce-module-constants #f])
+                       (compile-syntax e)))
+                   (lambda (ext loader?) (load-extension ext) #f)
+                   #:notify (lambda (chosen) (notify re? chosen))))
+
+(define ((make-loader orig re?) path name)
+  (when (inhibit-eval)
+    (raise (make-exn:fail "namespace not found" (current-continuation-marks))))
+  (if (module-name? name)
+      ;; Module load:
+      (with-handlers ([(lambda (exn)
+                         (and (pair? name) (exn:get-module-code? exn)))
+                       ;; Load-handler protocol: quiet failure when a
+                       ;; submodule is not found
+                       (lambda (exn) (void))])
+        (let* ([code (module-code re? name path)]
+               [dir (or (current-load-relative-directory) (current-directory))]
+               [path (path->complete-path path dir)]
+               [path (normal-case-path (simplify-path path))])
+          (define-values (ts real-path) (get-timestamp path))
+          (add-paths! (make-mod name path ts code) (resolve-paths path))
+          (parameterize ([current-module-declare-source real-path])
+            (eval code))))
+      ;; Not a module:
+      (begin (notify re? path) (orig path name))))
+
+(define (get-timestamp path)
+  (let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
+    (if ts
+        (values ts path)
+        (if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
+            (let* ([alt-path (path-replace-suffix path #".ss")]
+                   [ts (file-or-directory-modify-seconds alt-path
+                                                         #f
+                                                         (lambda () #f))])
+              (if ts
+                  (values ts alt-path)
+                  (values -inf.0 path)))
+            (values -inf.0 path)))))
+
+(define (check-latest mod)
+  (define mpi (module-path-index-join mod #f))
+  (define done (make-hash))
+  (let loop ([mpi mpi])
+    (define rindex (module-path-index-resolve mpi))
+    (define rpath (resolved-module-path-name rindex))
+    (define path (if (pair? rpath) (car rpath) rpath))
+    (when (path? path)
+      (define npath (normal-case-path path))
+      (unless (hash-ref done npath #f)
+        (hash-set! done npath #t)
+        (define mod (hash-ref loaded rpath #f))
+        (when mod
+          (for-each loop (mod-depends mod))
+          (define-values (ts actual-path) (get-timestamp npath))
+          (when (> ts (mod-timestamp mod))
+            (define orig (current-load/use-compiled))
+            (parameterize ([current-load/use-compiled
+                            (make-loader orig #f)]
+                           [current-module-declare-name rindex]
+                           [current-module-declare-source actual-path])
+              ((make-loader orig #f) npath (mod-name mod)))))))))

elpa/geiser-20171010.1610/scheme/racket/geiser/eval.rkt

@@ -0,0 +1,83 @@
+;;; eval.rkt -- evaluation
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
+
+;; 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 Apr 26, 2009 00:44
+
+#lang racket
+
+(provide eval-in
+         load-file
+         macroexpand
+         add-to-load-path
+         make-repl-reader
+         call-with-result)
+
+(require geiser/enter geiser/modules geiser/images)
+(require errortrace/errortrace-lib)
+
+(define last-result (void))
+
+(define last-namespace (make-parameter (current-namespace)))
+
+(define (exn-key e)
+  (vector-ref (struct->vector e) 0))
+
+(define (set-last-error e)
+  (set! last-result `((error (key . ,(exn-key e)))))
+  (display (exn-message e))
+  (newline) (newline)
+  (parameterize ([error-context-display-depth 10])
+    (print-error-trace (current-output-port) e)))
+
+(define (write-value v)
+  (with-output-to-string
+    (lambda () (maybe-write-image v))))
+
+(define (set-last-result . vs)
+  (set! last-result `((result ,@(map write-value vs)))))
+
+(define (call-with-result thunk)
+  (set-last-result (void))
+  (let ([output
+         (with-output-to-string
+           (lambda ()
+             (parameterize ([current-error-port (current-output-port)])
+               (with-handlers ([exn? set-last-error])
+                 (call-with-values thunk set-last-result)))))])
+    (append last-result `(,(cons 'output output)))))
+
+(define (eval-in form spec lang . non-top)
+  (write (call-with-result
+          (lambda ()
+            (eval (if (null? non-top) (cons '#%top-interaction form) form)
+                  (module-spec->namespace spec lang)))))
+  (newline))
+
+(define (load-file file)
+  (load-module file (current-output-port) (last-namespace)))
+
+(define (macroexpand form . all)
+  (let ([all (and (not (null? all)) (car all))])
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (syntax->datum ((if all expand expand-once) form)))))))
+
+(define (add-to-load-path p)
+  (when (string? p)
+    (let ([p (string->path p)]
+          [cps (current-library-collection-paths)])
+      (unless (member p cps)
+        (current-library-collection-paths
+         (cons p cps)))))
+  #t)
+
+(define (make-repl-reader reader)
+  (lambda ()
+    (last-namespace (current-namespace))
+    (reader)))

elpa/geiser-20171010.1610/scheme/racket/geiser/images.rkt

@@ -0,0 +1,66 @@
+;;; images.rkt -- support for image handline
+
+;; Copyright (C) 2012, 2014 Jose Antonio Ortega Ruiz
+
+;; 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>.
+
+;; Authors: Michael Wilber, Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Sep 2, 2012 18:54
+
+
+#lang racket/base
+
+(require racket/file file/convertible racket/pretty)
+(provide image-cache
+         maybe-print-image
+         maybe-write-image
+         make-port-print-handler
+         make-pretty-print-size-hook
+         make-pretty-print-print-hook)
+
+(define image-cache
+  (let ([ensure-dir (lambda (dir)
+                      (if (path-string? dir)
+                          (begin (make-directory* dir)
+                                 (if (path? dir) (path->string dir) dir))
+                          (path->string (find-system-path 'temp-dir))))])
+    (make-parameter (ensure-dir #f) ensure-dir)))
+
+(define (save-tmpimage imgbytes)
+  ;; Save imgbytes to a new temporary file and return the filename
+  (define filename (make-temporary-file "geiser-img-~a.png" #f (image-cache)))
+  (with-output-to-file filename #:exists 'truncate
+                       (lambda () (display imgbytes)))
+  (format "#<Image: ~a>" filename))
+
+(define (maybe-save-image value)
+  (and (convertible? value)
+       ;; (The above could be problematic if a future version of racket
+       ;; suddenly decides it can "convert" strings to picts)
+       (save-tmpimage (convert value 'png-bytes))))
+
+(define (maybe-print-image value)
+  (cond [(maybe-save-image value) => (lambda (s) (printf "~a\n" s))]
+        [else (unless (void? value)
+                (pretty-print value))]))
+
+(define (maybe-write-image value)
+  (write (or (maybe-save-image value) value)))
+
+(define (make-port-print-handler ph)
+  (lambda (value port . rest)
+    (apply ph (or (maybe-save-image value) value) port rest)))
+
+(define (make-pretty-print-size-hook [orig (pretty-print-size-hook)])
+  (lambda (value display? port)
+    (if (convertible? value)
+        (pretty-print-columns)
+        (orig value display? port))))
+
+(define (make-pretty-print-print-hook [orig (pretty-print-print-hook)])
+  (lambda (value display? port)
+    (let [(img (maybe-save-image value))]
+      (if img (print img port) (orig value display? port)))))

elpa/geiser-20171010.1610/scheme/racket/geiser/locations.rkt

@@ -0,0 +1,58 @@
+;;; locations.rkt -- locating symbols
+
+;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
+
+;; 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 Apr 26, 2009 19:43
+
+#lang racket
+
+(provide symbol-location
+         symbol-location*
+         module-location
+         symbol-module
+         symbol-module-name)
+
+(require geiser/utils geiser/modules)
+
+(define (symbol-location* sym)
+  (let* ([id (namespace-symbol->identifier sym)]
+         [binding (and id (identifier-binding id))])
+    (if (list? binding)
+        (cons
+         (cadr binding)
+         (resolved-module-path-name
+          (module-path-index-resolve (car binding))))
+        (cons sym #f))))
+
+(define (switch-extension path)
+  (if (regexp-match? "\\.rkt$" path)
+      (regexp-replace "\\.rkt$" path ".ss")
+      (regexp-replace "\\.ss$" path ".rkt")))
+
+(define (make-location name path line)
+  (let* ([path (if (path? path) (path->string path) #f)]
+         [path (and path (if (file-exists? path) path (switch-extension path)))])
+    (list (cons "name" name)
+          (cons "file" (or path '()))
+          (cons "line" (or line '())))))
+
+(define (symbol-location sym)
+  (let* ([loc (symbol-location* sym)]
+         [name (car loc)]
+         [path (cdr loc)])
+    (if path
+        (make-location name path #f)
+        (module-location sym))))
+
+(define symbol-module (compose cdr symbol-location*))
+
+(define symbol-module-name
+  (compose module-path-name->name symbol-module))
+
+(define (module-location sym)
+  (make-location sym (module-spec->path-name sym) 1))

elpa/geiser-20171010.1610/scheme/racket/geiser/main.rkt

@@ -0,0 +1,57 @@
+;;; main.rkt -- exported interface for emacs
+
+;; Copyright (C) 2010, 2011 Jose Antonio Ortega Ruiz
+
+;; 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: Wed Mar 31, 2010 21:14
+
+#lang racket/base
+
+(provide geiser:eval
+         geiser:compile
+         geiser:load-file
+         geiser:compile-file
+         geiser:macroexpand
+         geiser:completions
+         geiser:module-completions
+         geiser:symbol-location
+         geiser:module-location
+         geiser:module-exports
+         geiser:autodoc
+         geiser:symbol-documentation
+         geiser:help
+         geiser:no-values)
+
+(require geiser/eval
+         geiser/modules
+         geiser/completions
+         geiser/locations
+         geiser/autodoc)
+
+(define (geiser:eval lang)
+  (lambda (form spec)
+    (update-signature-cache spec form)
+    (eval-in form spec lang)))
+
+(define geiser:compile geiser:eval)
+
+(define (geiser:load-file file)
+  (update-signature-cache file)
+  (load-file file))
+
+(define geiser:compile-file geiser:load-file)
+(define geiser:add-to-load-path add-to-load-path)
+(define geiser:autodoc autodoc)
+(define geiser:help get-help)
+(define geiser:completions symbol-completions)
+(define geiser:module-completions module-completions)
+(define geiser:symbol-location symbol-location)
+(define geiser:module-location module-location)
+(define geiser:module-exports module-exports)
+(define geiser:macroexpand macroexpand)
+(define geiser:symbol-documentation symbol-documentation)
+(define (geiser:no-values) (values))

elpa/geiser-20171010.1610/scheme/racket/geiser/modules.rkt

@@ -0,0 +1,227 @@
+;;; modules.rkt -- module metadata
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Jose Antonio Ortega Ruiz
+
+;; 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: Wed May 06, 2009 02:35
+
+#lang racket
+
+(provide load-module
+         ensure-module-spec
+         module-spec->namespace
+	 namespace->module-name
+         namespace->module-path-name
+         module-path-name->name
+         module-spec->path-name
+         module-path-index->name
+         module-identifiers
+         module-list
+         submodules)
+
+(require srfi/13
+         syntax/modcode
+         syntax/modresolve
+         geiser/enter)
+
+(define (ensure-module-spec spec)
+  (cond [(symbol? spec) spec]
+        [(not (string? spec)) #f]
+        [else `(file ,spec)]))
+
+(define (module-spec->namespace spec (lang #f) (current #t))
+  (define (try-lang)
+    (and lang
+         (with-handlers ([exn? (const #f)])
+           (load-module lang #f (current-namespace))
+           (module->namespace lang))))
+  (or (get-namespace spec)
+      (try-lang)
+      (and current (current-namespace))))
+
+(define nowhere (open-output-nowhere))
+
+(define (load-module spec (port #f) (ns #f))
+  (parameterize ([current-error-port (or port nowhere)])
+    (visit-module (ensure-module-spec spec))
+    (when (namespace? ns)
+      (current-namespace ns))))
+
+(define (namespace->rmp ns)
+  (with-handlers ([exn? (const #f)])
+    (variable-reference->resolved-module-path
+     (eval '(#%variable-reference) (or ns (current-namespace))))))
+
+(define (namespace->module-path-name ns (p #f))
+  (let ([rmp (namespace->rmp ns)])
+    (or (and (resolved-module-path? rmp)
+             (resolved-module-path-name rmp))
+        p)))
+
+(define (module-spec->path-name spec)
+  (and (symbol? spec)
+       (or (get-path spec)
+           (register-path spec
+                          (namespace->module-path-name
+                           (module-spec->namespace spec #f #f))))))
+
+(define unknown-module-name "*unresolved module*")
+
+(define (unix-path->string path)
+  (regexp-replace* "\\\\" (path->string path) "/"))
+
+(define (path->name path)
+  (if (path-string? path)
+      (let* ([cpaths (map (compose unix-path->string path->directory-path)
+                          (current-library-collection-paths))]
+             [prefix-len (lambda (p)
+                           (let ((pl (string-length p)))
+                             (if (= pl (string-prefix-length p path))
+                                 pl
+                                 0)))]
+             [lens (map prefix-len cpaths)]
+             [real-path (substring path (apply max lens))])
+        (if (absolute-path? real-path)
+            (let-values ([(_ base __) (split-path path)])
+              (unix-path->string base))
+            (regexp-replace "\\.[^./]*$" real-path "")))
+      path))
+
+(define (module-path-name->name path)
+  (cond [(path? path) (module-path-name->name (unix-path->string path))]
+        ;; [(eq? path '#%kernel) "(kernel)"]
+        [(path-string? path) (path->name path)]
+        [(symbol? path) (symbol->string path)]
+        [(list? path) (string-join (map (compose path->name ~a) path) "/")]
+        [else (~a path)]))
+
+(define (module-path-index->name mpi)
+  (let ([rmp (module-path-index-resolve mpi)])
+    (if (resolved-module-path? rmp)
+        (module-path-name->name (resolved-module-path-name rmp))
+        unknown-module-name)))
+
+(define (namespace->module-name ns (p #f))
+  (module-path-name->name (namespace->module-path-name ns p)))
+
+(define (module-identifiers mod)
+  (define (extract-ids ls)
+    (append-map (lambda (idls)
+                  (map car (cdr idls)))
+                ls))
+  (let-values ([(reg syn)
+                (module-compiled-exports
+                 (get-module-code (resolve-module-path
+                                   (ensure-module-spec mod) #f)))])
+    (values (extract-ids reg) (extract-ids syn))))
+
+(define (skippable-dir? path)
+  (call-with-values (lambda () (split-path path))
+    (lambda (_ basename __)
+      (member (path->string basename) '(".svn" "compiled")))))
+
+(define path->symbol (compose string->symbol unix-path->string))
+
+(define (path->entry path)
+  (let ([ext (filename-extension path)])
+    (and ext
+         (or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
+         (not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
+         (let* ([path (unix-path->string path)]
+                [len (- (string-length path) (bytes-length ext) 1)])
+           (substring path 0 len)))))
+
+(define (ensure-path datum)
+  (if (string? datum)
+      (string->path datum)
+      datum))
+
+(define main-rkt (build-path "main.rkt"))
+(define main-ss (build-path "main.ss"))
+
+(define ((visit-module-path reg?) path kind acc)
+  (define (register e p)
+    (when reg?
+      (register-path (string->symbol e) (build-path (current-directory) p)))
+    (values (cons e acc) reg?))
+  (define (get-main path main)
+    (and (file-exists? main) (build-path path main)))
+  (define (find-main path)
+    (parameterize ([current-directory path])
+      (or (get-main path main-rkt) (get-main path main-ss))))
+  (case kind
+    [(file) (let ([entry (path->entry path)])
+              (if (not entry) acc (register entry path)))]
+    [(dir) (cond [(skippable-dir? path) (values acc #f)]
+                 [(find-main path) => (curry register (unix-path->string path))]
+                 [else (values acc reg?)])]
+    [else acc]))
+
+(define ((find-modules reg?) path acc)
+  (if (directory-exists? path)
+      (parameterize ([current-directory path])
+        (fold-files (visit-module-path reg?) acc))
+      acc))
+
+(define (take-while pred lst)
+  (let loop ([lst lst] [acc '()])
+    (cond [(null? lst) (reverse acc)]
+          [(pred (car lst)) (loop (cdr lst) (cons (car lst) acc))]
+          [else (reverse acc)])))
+
+(define (submodules mod)
+  (let* ([mod-name (if (symbol? mod) mod (get-mod mod))]
+         [mod-str (and (symbol? mod-name) (symbol->string mod-name))])
+    (if mod-str
+        (let ([ms (member mod-str (module-list))])
+          (and ms
+               (take-while (lambda (m) (string-prefix? mod-str m))
+                           (cdr ms))))
+        (find-submodules mod))))
+
+(define (find-submodules path)
+  (and (path-string? path)
+       (let-values ([(dir base ign) (split-path path)])
+         (and (or (equal? base main-rkt)
+                  (equal? base main-ss))
+              (map (lambda (m) (unix-path->string (build-path dir m)))
+                   (remove "main" ((find-modules #f) dir '())))))))
+
+(define (known-modules)
+  (sort (foldl (find-modules #t)
+               '()
+               (current-library-collection-paths))
+        string<?))
+
+(define registered (make-hash))
+(define registered-paths (make-hash))
+
+(define (get-path mod)
+  (hash-ref registered mod #f))
+
+(define (get-mod path)
+  (hash-ref registered-paths path #f))
+
+(define (register-path mod path)
+  (hash-set! registered mod path)
+  (hash-set! registered-paths path mod)
+  path)
+
+(define module-cache #f)
+
+(define (update-module-cache)
+  (when (not module-cache) (set! module-cache (known-modules))))
+
+(define (module-list)
+  (update-module-cache)
+  module-cache)
+
+(define (startup)
+ (thread update-module-cache)
+ (void))
+
+(startup)

elpa/geiser-20171010.1610/scheme/racket/geiser/server.rkt

@@ -0,0 +1,16 @@
+;;; server.rkt -- REPL server
+
+;; Copyright (c) 2010 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Nov 06, 2010 15:15
+
+#lang racket/base
+
+(require geiser/user)
+(provide start-geiser)
+

elpa/geiser-20171010.1610/scheme/racket/geiser/startup.rkt

@@ -0,0 +1,15 @@
+;;; startup.rkt -- entry point
+
+;; Copyright (C) 2009, 2010, 2013, 2014 Jose Antonio Ortega Ruiz
+
+;; 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: Sat Apr 25, 2009 22:36
+
+;; (require errortrace)
+(require geiser/user)
+
+(init-geiser-repl)

elpa/geiser-20171010.1610/scheme/racket/geiser/user.rkt

@@ -0,0 +1,172 @@
+;;; user.rkt -- global bindings visible to geiser users
+
+;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
+
+;; 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: Wed Mar 31, 2010 22:24
+
+#lang racket
+
+(provide init-geiser-repl run-geiser-server start-geiser)
+
+(require (for-syntax racket/base)
+         mzlib/thread
+         racket/tcp
+         racket/help
+         geiser
+         geiser/autodoc
+         geiser/images
+         geiser/enter
+         geiser/eval
+         geiser/modules)
+
+(define top-namespace (current-namespace))
+(define last-entered (make-parameter ""))
+
+(define (do-enter mod name)
+  (visit-module mod)
+  (last-entered name)
+  (current-namespace (module->namespace mod)))
+
+(define (file-mod? mod)
+  (and (list? mod)
+       (= 2 (length mod))
+       (eq? 'file (car mod))
+       (path-string? (cadr mod))))
+
+(define (submod-path mod)
+  (and (list? mod)
+       (eq? 'submod (car mod))
+       (> (length mod) 1)
+       (let ([parent (cadr mod)])
+         (cond [(path-string? parent) `(submod (file ,parent) ,@(cddr mod))]
+               [(file-mod? parent) mod]
+               [(symbol? parent) mod]
+               [else #f]))))
+
+(define (module-error stx mod)
+  (raise-syntax-error #f "Invalid module path" stx mod))
+
+(define (enter! mod stx)
+  (cond [(not mod)
+         (current-namespace top-namespace)
+         (last-entered "")]
+        [(symbol? mod) (do-enter mod (symbol->string mod))]
+        [(path-string? mod) (do-enter `(file ,mod) mod)]
+        [(file-mod? mod) (do-enter mod (cadr mod))]
+        [(submod-path mod) => (lambda (m) (do-enter m m))]
+        [else (module-error stx mod)]))
+
+(define (geiser-eval)
+  (define geiser-main (module->namespace 'geiser))
+  (define (eval-here form) (eval form geiser-main))
+  (let* ([mod (read)]
+         [lang (read)]
+         [form (read)]
+         [res (cond [(equal? form '(unquote apply))
+                     (let* ([proc (eval-here (read))]
+                            [args (map eval-here (read))]
+                            [ev (lambda () (apply proc args))])
+                       (eval-in `(,ev) mod lang #t))]
+                    [else ((geiser:eval lang) form mod)])])
+    (datum->syntax #f (list 'quote res))))
+
+(define (geiser-load stx)
+  (let* ([mod (read)]
+         [res (call-with-result
+               (lambda ()
+                 (visit-module (cond [(file-mod? mod) mod]
+                                     [(path-string? mod) `(file ,mod)]
+                                     [(submod-path mod)]
+                                     [else (module-error stx mod)]))
+                 (void)))])
+    (datum->syntax stx (list 'quote res))))
+
+(define ((geiser-read prompt))
+  (prompt)
+  (flush-output (current-error-port))
+  (flush-output (current-output-port))
+  (let* ([in ((current-get-interaction-input-port))]
+	 [form ((current-read-interaction) (object-name in) in)])
+    (syntax-case form ()
+      [(uq cmd) (eq? 'unquote (syntax-e #'uq))
+       (case (syntax-e #'cmd)
+         [(start-geiser) (datum->syntax #f `(list 'port ,(start-geiser)))]
+         [(enter) (enter! (read) #'cmd)]
+         [(geiser-eval) (geiser-eval)]
+         [(geiser-load) (geiser-load #'cmd)]
+         [(geiser-no-values) (datum->syntax #f (void))]
+         [(add-to-load-path) (add-to-load-path (read))]
+         [(set-image-cache) (image-cache (read))]
+         [(help) (get-help (read) (read))]
+         [(image-cache) (image-cache)]
+         [(pwd) (~a (current-directory))]
+         [(cd) (current-directory (~a (read)))]
+         [else form])]
+      [_ form])))
+
+(define geiser-prompt
+  (lambda ()
+    (let ([m (namespace->module-name (current-namespace) (last-entered))])
+      (printf "racket@~a> " (regexp-replace* " " m "_")))))
+
+(define (geiser-prompt-read prompt)
+  (make-repl-reader (geiser-read prompt)))
+
+(define (geiser-loader) (module-loader (current-load/use-compiled)))
+
+(define (install-print-handler handler)
+  (let ([p (current-output-port)])
+    (handler p (make-port-print-handler (handler p)))))
+
+(define (install-print-handlers)
+  (for-each install-print-handler (list port-print-handler
+                                        port-write-handler
+                                        port-display-handler))
+  (pretty-print-print-hook (make-pretty-print-print-hook))
+  (pretty-print-size-hook (make-pretty-print-size-hook)))
+
+(define (init-geiser-repl)
+  (compile-enforce-module-constants #f)
+  (current-load/use-compiled (geiser-loader))
+  (preload-help)
+  (current-prompt-read (geiser-prompt-read geiser-prompt))
+  (current-print maybe-print-image)
+  (install-print-handlers))
+
+(define (run-geiser-repl in out enforce-module-constants)
+  (parameterize [(compile-enforce-module-constants enforce-module-constants)
+                 (current-input-port in)
+                 (current-output-port out)
+                 (current-error-port out)
+                 (current-load/use-compiled (geiser-loader))
+                 (current-prompt-read (geiser-prompt-read geiser-prompt))
+                 (current-print maybe-print-image)
+                 (pretty-print-print-hook (make-pretty-print-print-hook))
+                 (pretty-print-size-hook (make-pretty-print-size-hook))]
+    (install-print-handlers)
+    (preload-help)
+    (read-eval-print-loop)))
+
+(define server-channel (make-channel))
+
+(define (run-geiser-server port enforce-module-constants (hostname #f))
+  (run-server port
+              (lambda (in out)
+                (run-geiser-repl in out enforce-module-constants))
+              #f
+              void
+              (lambda (p _ __)
+                (let ([lsner (tcp-listen p 4 #f hostname)])
+                  (let-values ([(_ p __ ___) (tcp-addresses lsner #t)])
+                    (channel-put server-channel p)
+                    lsner)))))
+
+(define (start-geiser (port 0) (hostname #f) (enforce-module-constants #f))
+  (thread (lambda ()
+            (run-geiser-server port enforce-module-constants hostname)))
+  (channel-get server-channel))

elpa/geiser-20171010.1610/scheme/racket/geiser/utils.rkt

@@ -0,0 +1,25 @@
+;;; utils.rkt -- generic utilities
+
+;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
+
+;; 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 May 03, 2009 03:09
+
+#lang racket
+
+(provide pair->list
+         keyword->symbol
+         symbol->keyword)
+
+(define (pair->list pair)
+  (let loop ([d pair] [s '()])
+    (cond [(null? d) (reverse s)]
+          [(symbol? d) (reverse (cons d s))]
+          [else (loop (cdr d) (cons (car d) s))])))
+
+(define keyword->symbol (compose string->symbol keyword->string))
+(define (symbol->keyword sym) (string->keyword (format "~a" sym)))

elpa/geiser-20171010.1610/top.info

@@ -0,0 +1,23 @@
+This is top.info, produced by makeinfo version 5.2 from top.texi.
+
+Geiser is a collection of Emacs major and minor modes that conspire with
+one or more Scheme interpreters to keep the Lisp Machine Spirit alive.
+It draws inspiration (and a bit more) from environments such as Common
+Lisp's Slime, Factor's FUEL, Squeak or Emacs itself, and does its best
+to make Scheme hacking inside Emacs (even more) fun.
+
+   Or, to be precise, what i (http://hacks-galore.org/jao) consider fun.
+Geiser is thus my humble contribution to the dynamic school of
+expression, and a reaction against what i perceive as a derailment, in
+modern times, of standard Scheme towards the static camp.  Because i
+prefer growing and healing to poking at corpses, the continuously
+running Scheme interpreter takes the center of the stage in Geiser.  A
+bundle of Elisp shims orchestrates the dialog between the Scheme
+interpreter, Emacs and, ultimately, the schemer, giving her access to
+live metadata.  Here's how.
+
+
+
+Tag Table:
+
+End Tag Table