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   (not (memq feat geiser-eval--unsupported)))
  57
  58 (defsubst geiser-eval--form (proc)
  59   (when (and geiser-eval--unsupported (memq proc geiser-eval--unsupported))
  60     (error "Sorry, the %s scheme implementation does not support Geiser's %s"
  61            geiser-impl--implementation proc))
  62   (funcall geiser-eval--geiser-procedure-function proc))
  63
  64 \f
  65 ;;; Code formatting:
  66
  67 (defsubst geiser-eval--eval (code)
  68   (geiser-eval--scheme-str
  69    `(,(geiser-eval--form 'eval) (quote ,(nth 0 code))
  70      (:module ,(nth 1 code)))))
  71
  72 (defsubst geiser-eval--comp (code)
  73   (geiser-eval--scheme-str
  74    `(,(geiser-eval--form 'compile)
  75      (quote ,(nth 0 code)) (:module ,(nth 1 code)))))
  76
  77 (defsubst geiser-eval--load-file (file)
  78   (geiser-eval--scheme-str `(,(geiser-eval--form 'load-file) ,file)))
  79
  80 (defsubst geiser-eval--comp-file (file)
  81   (geiser-eval--scheme-str `(,(geiser-eval--form 'compile-file) ,file)))
  82
  83 (defsubst geiser-eval--module (code)
  84   (geiser-eval--scheme-str
  85    (cond ((or (null code) (eq code :t) (eq code :buffer))
  86           (list 'quote (funcall geiser-eval--get-module-function)))
  87          ((or (eq code :repl) (eq code :f)) :f)
  88          (t (list 'quote (funcall geiser-eval--get-module-function code))))))
  89
  90 (defsubst geiser-eval--ge (proc)
  91   (geiser-eval--scheme-str (geiser-eval--form proc)))
  92
  93 (defun geiser-eval--scheme-str (code)
  94   (cond ((null code) "'()")
  95         ((eq code :f) "#f")
  96         ((eq code :t) "#t")
  97         ((listp code)
  98          (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code)))
  99                ((eq (car code) :comp) (geiser-eval--comp (cdr code)))
 100                ((eq (car code) :load-file)
 101                 (geiser-eval--load-file (cadr code)))
 102                ((eq (car code) :comp-file)
 103                 (geiser-eval--comp-file (cadr code)))
 104                ((eq (car code) :module) (geiser-eval--module (cadr code)))
 105                ((eq (car code) :ge) (geiser-eval--ge (cadr code)))
 106                ((eq (car code) :scm) (cadr code))
 107                (t (concat "("
 108                           (mapconcat 'geiser-eval--scheme-str code " ")
 109                           ")"))))
 110         ((symbolp code) (format "%s" code))
 111         (t (format "%S" code))))
 112
 113 \f
 114 ;;; Code sending:
 115
 116 (defvar geiser-eval--default-proc-function nil)
 117
 118 (defsubst geiser-eval--proc ()
 119   (and geiser-eval--default-proc-function
 120        (funcall geiser-eval--default-proc-function)))
 121
 122 (defsubst geiser-eval--log (s)
 123   (geiser-log--info "RETORT: %S" s)
 124   s)
 125
 126 (defsubst geiser-eval--code-str (code)
 127   (if (stringp code) code (geiser-eval--scheme-str code)))
 128
 129 (defvar geiser-eval--sync-retort nil)
 130 (defun geiser-eval--set-sync-retort (s)
 131   (setq geiser-eval--sync-retort (geiser-eval--log s)))
 132
 133 (defsubst geiser-eval--send (code cont &optional buffer)
 134   (geiser-con--send-string (geiser-eval--proc)
 135                            (geiser-eval--code-str code)
 136                            `(lambda (s) (,cont (geiser-eval--log s)))
 137                            buffer))
 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