1 ;;; geiser-eval.el -- sending scheme code for evaluation
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015 Jose Antonio Ortega Ruiz
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>.
10 ;; Start date: Sat Feb 07, 2009 22:35
12 ;; Functions, building on top of geiser-connection, to evaluate scheme
17 (require 'geiser-impl
)
18 (require 'geiser-connection
)
19 (require 'geiser-syntax
)
21 (require 'geiser-base
)
24 ;;; Plug-able functions:
26 (make-variable-buffer-local
27 (defvar geiser-eval--get-module-function nil
))
28 (set-default 'geiser-eval--get-module-function nil
)
30 (defvar geiser-eval--get-impl-module nil
)
31 (geiser-impl--register-local-method
32 'geiser-eval--get-impl-module
'find-module
'(lambda (&rest args
) nil
)
33 "Function used to obtain the module for current buffer. It takes
34 an optional argument, for cases where we want to force its
37 (defun geiser-eval--get-module (&optional module
)
38 (if geiser-eval--get-module-function
39 (funcall geiser-eval--get-module-function module
)
40 (funcall geiser-eval--get-impl-module module
)))
42 (defvar geiser-eval--geiser-procedure-function
)
43 (geiser-impl--register-local-method
44 'geiser-eval--geiser-procedure-function
'marshall-procedure
'identity
45 "Function to translate a bare procedure symbol to one executable
46 in the Scheme context. Return NULL for unsupported ones; at the
47 very least, EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be
50 (defvar geiser-eval--unsupported nil
)
51 (geiser-impl--register-local-variable
52 'geiser-eval--unsupported
'unsupported-procedures nil
53 "A list, or function returning a list, of the Geiser procedures
54 not implemented by this Scheme implementation. Possible values
55 include macroexpand, completions, module-completions, find-file,
56 symbol-location, module-location, symbol-documentation,
57 module-exports, autodoc, callers, callees and generic-methods.")
59 (defun geiser-eval--supported-p (feat)
60 (or (not geiser-eval--unsupported
)
61 (not (memq feat geiser-eval--unsupported
))))
63 (defsubst geiser-eval--form
(&rest args
)
64 (when (not (geiser-eval--supported-p (car args
)))
65 (error "Sorry, the %s scheme implementation does not support Geiser's %s"
66 geiser-impl--implementation
(car args
)))
67 (apply geiser-eval--geiser-procedure-function args
))
72 (defsubst geiser-eval--load-file
(file)
73 (geiser-eval--form 'load-file
74 (geiser-eval--scheme-str file
)))
76 (defsubst geiser-eval--comp-file
(file)
77 (geiser-eval--form 'compile-file
78 (geiser-eval--scheme-str file
)))
80 (defsubst geiser-eval--module
(code)
81 (geiser-eval--scheme-str
82 (cond ((or (null code
) (eq code
:t
) (eq code
:buffer
))
83 (geiser-eval--get-module))
84 ((or (eq code
:repl
) (eq code
:f
)) :f
)
85 (t (geiser-eval--get-module code
)))))
87 (defsubst geiser-eval--eval
(code)
88 (geiser-eval--form 'eval
89 (geiser-eval--module (nth 1 code
))
90 (geiser-eval--scheme-str (nth 0 code
))))
92 (defsubst geiser-eval--comp
(code)
93 (geiser-eval--form 'compile
94 (geiser-eval--module (nth 1 code
))
95 (geiser-eval--scheme-str (nth 0 code
))))
97 (defsubst geiser-eval--ge
(proc args
)
98 (apply 'geiser-eval--form
(cons proc
99 (mapcar 'geiser-eval--scheme-str args
))))
101 (defun geiser-eval--scheme-str (code)
102 (cond ((null code
) "'()")
106 (cond ((eq (car code
) :eval
) (geiser-eval--eval (cdr code
)))
107 ((eq (car code
) :comp
) (geiser-eval--comp (cdr code
)))
108 ((eq (car code
) :load-file
)
109 (geiser-eval--load-file (cadr code
)))
110 ((eq (car code
) :comp-file
)
111 (geiser-eval--comp-file (cadr code
)))
112 ((eq (car code
) :module
) (geiser-eval--module (cadr code
)))
113 ((eq (car code
) :ge
) (geiser-eval--ge (cadr code
)
115 ((eq (car code
) :scm
) (cadr code
))
117 (mapconcat 'geiser-eval--scheme-str code
" ")
119 ((symbolp code
) (substring-no-properties (format "%s" code
)))
120 (t (substring-no-properties (format "%S" code
)))))
125 (defvar geiser-eval--default-connection-function nil
)
127 (defsubst geiser-eval--connection
()
128 (and geiser-eval--default-connection-function
129 (funcall geiser-eval--default-connection-function
)))
131 (defsubst geiser-eval--log
(s)
132 (geiser-log--info "RETORT: %S" s
)
135 (defsubst geiser-eval--code-str
(code)
136 (if (stringp code
) code
(geiser-eval--scheme-str code
)))
138 (defsubst geiser-eval--send
(code cont
&optional buffer
)
139 (geiser-con--send-string (geiser-eval--connection)
140 (geiser-eval--code-str code
)
144 (defvar geiser-eval--sync-retort nil
)
145 (defun geiser-eval--set-sync-retort (s)
146 (setq geiser-eval--sync-retort
(geiser-eval--log s
)))
148 (defun geiser-eval--send/wait
(code &optional timeout buffer
)
149 (setq geiser-eval--sync-retort nil
)
150 (geiser-con--send-string/wait
(geiser-eval--connection)
151 (geiser-eval--code-str code
)
152 'geiser-eval--set-sync-retort
155 geiser-eval--sync-retort
)
160 (defsubst geiser-eval--retort-p
(ret)
161 (and (listp ret
) (or (assoc 'error ret
) (assoc 'result ret
))))
163 (defsubst geiser-eval--retort-result
(ret)
164 (let ((values (cdr (assoc 'result ret
))))
165 (car (geiser-syntax--read-from-string (car values
)))))
167 (defsubst geiser-eval--send
/result
(code &optional timeout buffer
)
168 (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer
)))
170 (defun geiser-eval--retort-result-str (ret prefix
)
171 (let* ((prefix (or prefix
"=> "))
172 (nlprefix (concat "\n" prefix
))
173 (values (cdr (assoc 'result ret
))))
175 (concat prefix
(mapconcat 'identity values nlprefix
))
176 (or prefix
"(No value)"))))
178 (defsubst geiser-eval--retort-output
(ret)
179 (cdr (assq 'output ret
)))
181 (defsubst geiser-eval--retort-error
(ret)
182 (cdr (assq 'error ret
)))
184 (defsubst geiser-eval--error-key
(err)
185 (cdr (assq 'key err
)))
187 (defsubst geiser-eval--error-subr
(err)
188 (cdr (assq 'subr err
)))
190 (defsubst geiser-eval--error-msg
(err)
191 (cdr (assq 'msg err
)))
193 (defsubst geiser-eval--error-rest
(err)
194 (cdr (assq 'rest err
)))
196 (defun geiser-eval--error-str (err)
197 (let* ((key (geiser-eval--error-key err
))
198 (key-str (if key
(format ": %s" key
) ":"))
199 (subr (geiser-eval--error-subr err
))
200 (subr-str (if subr
(format " (%s):" subr
) ""))
201 (msg (geiser-eval--error-msg err
))
202 (msg-str (if msg
(format "\n %s" msg
) ""))
203 (rest (geiser-eval--error-rest err
))
204 (rest-str (if rest
(format "\n %s" rest
) "")))
205 (format "Error%s%s%s%s" subr-str key-str msg-str rest-str
)))
209 (provide 'geiser-eval
)