1 ;;; geiser-eval.el -- sending scheme code for evaluation
3 ;; Copyright (C) 2009, 2010 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 (defvar geiser-eval--get-module-function nil
)
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
34 (defsubst geiser-eval--get-module
(&optional module
)
35 (and geiser-eval--get-module-function
36 (funcall geiser-eval--get-module-function module
)))
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
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.")
55 (defun geiser-eval--supported-p (feat)
56 (or (not geiser-eval--unsupported
)
57 (not (memq feat geiser-eval--unsupported
))))
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
))
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
))))
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
))))
78 (defsubst geiser-eval--load-file
(file)
79 (geiser-eval--form 'load-file
80 (geiser-eval--scheme-str file
)))
82 (defsubst geiser-eval--comp-file
(file)
83 (geiser-eval--form 'compile-file
84 (geiser-eval--scheme-str file
)))
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
)))))
93 (defsubst geiser-eval--ge
(proc args
)
94 (apply 'geiser-eval--form
(cons proc
95 (mapcar 'geiser-eval--scheme-str args
))))
97 (defun geiser-eval--scheme-str (code)
98 (cond ((null 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
)
111 ((eq (car code
) :scm
) (cadr code
))
113 (mapconcat 'geiser-eval--scheme-str code
" ")
115 ((symbolp code
) (format "%s" code
))
116 ((stringp code
) (format "%S" (substring-no-properties code
)))
117 (t (format "%S" code
))))
122 (defvar geiser-eval--default-proc-function nil
)
124 (defsubst geiser-eval--proc
()
125 (and geiser-eval--default-proc-function
126 (funcall geiser-eval--default-proc-function
)))
128 (defsubst geiser-eval--log
(s)
129 (geiser-log--info "RETORT: %S" s
)
132 (defsubst geiser-eval--code-str
(code)
133 (if (stringp code
) code
(geiser-eval--scheme-str code
)))
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
)))
139 (defsubst geiser-eval--send
(code cont
&optional buffer
)
140 (geiser-con--send-string (geiser-eval--proc)
141 (geiser-eval--code-str code
)
142 `(lambda (s) (,cont
(geiser-eval--log s
)))
145 (defun geiser-eval--send/wait
(code &optional timeout buffer
)
146 (setq geiser-eval--sync-retort nil
)
147 (geiser-con--send-string/wait
(geiser-eval--proc)
148 (geiser-eval--code-str code
)
149 'geiser-eval--set-sync-retort
152 geiser-eval--sync-retort
)
154 (defsubst geiser-eval--send
/result
(code &optional timeout buffer
)
155 (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer
)))
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 (defun geiser-eval--retort-result-str (ret)
168 (let ((values (cdr (assoc 'result ret
))))
170 (concat "=> " (mapconcat 'identity values
"\n=> "))
173 (defsubst geiser-eval--retort-output
(ret) (cdr (assoc 'output ret
)))
174 (defsubst geiser-eval--retort-error
(ret) (cdr (assoc 'error ret
)))
176 (defsubst geiser-eval--error-key
(err) (cdr (assoc 'key err
)))
177 (defsubst geiser-eval--error-subr
(err) (cdr (assoc 'subr err
)))
178 (defsubst geiser-eval--error-msg
(err) (cdr (assoc 'msg err
)))
179 (defsubst geiser-eval--error-rest
(err) (cdr (assoc 'rest err
)))
181 (defun geiser-eval--error-str (err)
182 (let* ((key (geiser-eval--error-key err
))
183 (key-str (if key
(format ": %s" key
) ":"))
184 (subr (geiser-eval--error-subr err
))
185 (subr-str (if subr
(format " (%s):" subr
) ""))
186 (msg (geiser-eval--error-msg err
))
187 (msg-str (if msg
(format "\n %s" msg
) ""))
188 (rest (geiser-eval--error-rest err
))
189 (rest-str (if rest
(format "\n %s" rest
) "")))
190 (format "Error%s%s%s%s" subr-str key-str msg-str rest-str
)))
194 (provide 'geiser-eval
)
195 ;;; geiser-eval.el ends here