elisp/geiser-eval.el

   1 ;;; geiser-eval.el -- sending scheme code for evaluation
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sat Feb 07, 2009 22:35
  11
  12 ;; Functions, building on top of geiser-connection, to evaluate scheme
  13 ;; code.
  14
  15 \f
  16
  17 (require 'geiser-impl)
  18 (require 'geiser-connection)
  19 (require 'geiser-syntax)
  20 (require 'geiser-log)
  21 (require 'geiser-base)
  22
  23 \f
  24 ;;; Plug-able functions:
  25
  26 (defvar geiser-eval--get-module-function nil)
  27
  28 (geiser-impl--register-local-method
  29  'geiser-eval--get-module-function 'find-module '(lambda (&rest) nil)
  30  "Function used to obtain the module for current buffer. It takes
  31 an optional argument, for cases where we want to force its
  32 value.")
  33
  34 (defsubst geiser-eval--get-module (&optional module)
  35   (and geiser-eval--get-module-function
  36        (funcall geiser-eval--get-module-function module)))
  37
  38 (defvar geiser-eval--geiser-procedure-function nil)
  39 (geiser-impl--register-local-method
  40  'geiser-eval--geiser-procedure-function 'marshall-procedure 'identity
  41  "Function to translate a bare procedure symbol to one executable
  42 in the Scheme context. Return NULL for unsupported ones; at the
  43 very least, EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be
  44 supported.")
  45
  46 (defvar geiser-eval--unsupported nil)
  47 (geiser-impl--register-local-variable
  48  'geiser-eval--unsupported 'unsupported-procedures nil
  49  "A list, or function returning a list, of the Geiser procedures
  50 not implemented by this Scheme implementation. Possible values
  51 include macroexpand, completions, module-completions, find-file,
  52 symbol-location, module-location, symbol-documentation,
  53 module-exports, autodoc, callers, callees and generic-methods.")
  54
  55 (defun geiser-eval--supported-p (feat)
  56   (or (not geiser-eval--unsupported)
  57       (not (memq feat geiser-eval--unsupported))))
  58
  59 (defsubst geiser-eval--form (&rest args)
  60   (when (not (geiser-eval--supported-p (car args)))
  61     (error "Sorry, the %s scheme implementation does not support Geiser's %s"
  62            geiser-impl--implementation (car args)))
  63   (apply geiser-eval--geiser-procedure-function args))
  64
  65 \f
  66 ;;; Code formatting:
  67
  68 (defsubst geiser-eval--eval (code)
  69   (geiser-eval--form 'eval
  70                      (geiser-eval--module (nth 1 code))
  71                      (geiser-eval--scheme-str (nth 0 code))))
  72
  73 (defsubst geiser-eval--comp (code)
  74   (geiser-eval--form 'compile
  75                      (geiser-eval--module (nth 1 code))
  76                      (geiser-eval--scheme-str (nth 0 code))))
  77
  78 (defsubst geiser-eval--load-file (file)
  79   (geiser-eval--form 'load-file
  80                      (geiser-eval--scheme-str file)))
  81
  82 (defsubst geiser-eval--comp-file (file)
  83   (geiser-eval--form 'compile-file
  84                      (geiser-eval--scheme-str file)))
  85
  86 (defsubst geiser-eval--module (code)
  87   (geiser-eval--scheme-str
  88    (cond ((or (null code) (eq code :t) (eq code :buffer))
  89           (funcall geiser-eval--get-module-function))
  90          ((or (eq code :repl) (eq code :f)) :f)
  91          (t (funcall geiser-eval--get-module-function code)))))
  92
  93 (defsubst geiser-eval--ge (proc args)
  94   (apply 'geiser-eval--form (cons proc
  95                                   (mapcar 'geiser-eval--scheme-str args))))
  96
  97 (defun geiser-eval--scheme-str (code)
  98   (cond ((null code) "'()")
  99         ((eq code :f) "#f")
 100         ((eq code :t) "#t")
 101         ((listp code)
 102          (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code)))
 103                ((eq (car code) :comp) (geiser-eval--comp (cdr code)))
 104                ((eq (car code) :load-file)
 105                 (geiser-eval--load-file (cadr code)))
 106                ((eq (car code) :comp-file)
 107                 (geiser-eval--comp-file (cadr code)))
 108                ((eq (car code) :module) (geiser-eval--module (cadr code)))
 109                ((eq (car code) :ge) (geiser-eval--ge (cadr code)
 110                                                      (cddr code)))
 111                ((eq (car code) :scm) (cadr code))
 112                (t (concat "("
 113                           (mapconcat 'geiser-eval--scheme-str code " ")
 114                           ")"))))
 115         ((symbolp code) (format "%s" code))
 116         ((stringp code) (format "%S" (substring-no-properties code)))
 117         (t (format "%S" code))))
 118
 119 \f
 120 ;;; Code sending:
 121
 122 (defvar geiser-eval--default-proc-function nil)
 123
 124 (defsubst geiser-eval--proc ()
 125   (and geiser-eval--default-proc-function
 126        (funcall geiser-eval--default-proc-function)))
 127
 128 (defsubst geiser-eval--log (s)
 129   (geiser-log--info "RETORT: %S" s)
 130   s)
 131
 132 (defsubst geiser-eval--code-str (code)
 133   (if (stringp code) code (geiser-eval--scheme-str code)))
 134
 135 (defvar geiser-eval--sync-retort nil)
 136 (defun geiser-eval--set-sync-retort (s)
 137   (setq geiser-eval--sync-retort (geiser-eval--log s)))
 138
 139 (defun geiser-eval--send/wait (code &optional timeout buffer)
 140   (setq geiser-eval--sync-retort nil)
 141   (geiser-con--send-string/wait (geiser-eval--proc)
 142                                 (geiser-eval--code-str code)
 143                                 'geiser-eval--set-sync-retort
 144                                 timeout
 145                                 buffer)
 146   geiser-eval--sync-retort)
 147
 148 (defsubst geiser-eval--send/result (code &optional timeout buffer)
 149   (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer)))
 150
 151 \f
 152 ;;; Retort parsing:
 153
 154 (defsubst geiser-eval--retort-p (ret)
 155   (and (listp ret) (or (assoc 'error ret) (assoc 'result ret))))
 156
 157 (defsubst geiser-eval--retort-result (ret)
 158   (let ((values (cdr (assoc 'result ret))))
 159     (car (geiser-syntax--read-from-string (car values)))))
 160
 161 (defun geiser-eval--retort-result-str (ret)
 162   (let ((values (cdr (assoc 'result ret))))
 163     (if values
 164         (concat "=> " (mapconcat 'identity values "\n=> "))
 165       "(No value)")))
 166
 167 (defsubst geiser-eval--retort-output (ret) (cdr (assoc 'output ret)))
 168 (defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret)))
 169
 170 (defsubst geiser-eval--error-key (err) (cdr (assoc 'key err)))
 171 (defsubst geiser-eval--error-subr (err) (cdr (assoc 'subr err)))
 172 (defsubst geiser-eval--error-msg (err) (cdr (assoc 'msg err)))
 173 (defsubst geiser-eval--error-rest (err) (cdr (assoc 'rest err)))
 174
 175 (defun geiser-eval--error-str (err)
 176   (let* ((key (geiser-eval--error-key err))
 177          (key-str (if key (format ": %s" key) ":"))
 178          (subr (geiser-eval--error-subr err))
 179          (subr-str (if subr (format " (%s):" subr) ""))
 180          (msg (geiser-eval--error-msg err))
 181          (msg-str (if msg (format "\n  %s" msg) ""))
 182          (rest (geiser-eval--error-rest err))
 183          (rest-str (if rest (format "\n  %s" rest) "")))
 184     (format "Error%s%s%s%s" subr-str key-str msg-str rest-str)))
 185
 186
 187 \f
 188 (provide 'geiser-eval)
 189 ;;; geiser-eval.el ends here