Basic Guile/Emacs connection and evaluation working.

1 files changed, 112 insertions, 0 deletions

diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el
new file mode 100644
index 0000000..74c9b29
--- /dev/null
+++ b/elisp/geiser-eval.el
@@ -0,0 +1,112 @@
+;; geiser-eval.el -- sending scheme code for evaluation
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sat Feb 07, 2009 22:35
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Functions, building on top of geiser-connection, to evaluate scheme
+;; code.
+
+;;; Code:
+
+(require 'geiser-connection)
+(require 'geiser-log)
+(require 'geiser-base)
+
+
+;;; Code formatting:
+
+(defun geiser-eval--scheme-str (code)
+  (cond ((null code) "'()")
+        ((eq code :f) "#f")
+        ((eq code :t) "#t")
+        ((listp code)
+         (cond ((eq (car code) :gs) (concat "((@ (geiser eval) eval-in) (quote "
+                                            (geiser-eval--scheme-str (nth 1 code))
+                                            ") "
+                                            (or (nth 2 code)
+                                                (geiser-eval--buffer-module))
+                                            ")"))
+               ((eq (car code) :scm) (cadr code))
+               (t (concat "(" (mapconcat 'geiser-eval--scheme-str code " ") ")"))))
+        (t (format "%S" code))))
+
+
+;;; Current module:
+
+(defun geiser-eval--buffer-module (&optional buffer)
+  (let ((buffer (or buffer (current-buffer))))
+    (with-current-buffer buffer
+      (save-excursion
+        (goto-char (point-min))
+        (if (re-search-forward "(define-module +\\(([^)]+)\\)" nil t)
+            (match-string-no-properties 1)
+          "#f")))))
+
+
+;;; Code sending:
+
+(defvar geiser-eval--default-proc-function nil)
+
+(defsubst geiser-eval--default-proc ()
+  (and geiser-eval--default-proc-function
+       (funcall geiser-eval--default-proc-function)))
+
+(defvar geiser-eval--proc nil)
+
+(defsubst geiser-eval--proc ()
+  (or geiser-eval--proc (geiser-eval--default-proc)))
+
+(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)))
+
+(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--proc)
+                                (geiser-eval--code-str code)
+                                'geiser-eval--set-sync-retort
+                                timeout
+                                buffer)
+  geiser-eval--sync-retort)
+
+(defsubst geiser-eval--send (code cont &optional buffer)
+  (geiser-con--send-string (geiser-eval--proc)
+                           (geiser-eval--code-str code)
+                           `(lambda (s) (,cont (geiser-eval--log s)))
+                           buffer))
+
+
+;;; Retort parsing:
+
+(defsubst geiser-eval--retort-p (ret)
+  (and (listp ret) (or (assoc 'error ret) (assoc 'result ret))))
+(defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret)))
+(defsubst geiser-eval--retort-result (ret) (cdr (assoc 'result ret)))
+
+
+(provide 'geiser-eval)
+;;; geiser-eval.el ends here