geiser-eval.el (8243B)
1 ;;; geiser-eval.el -- sending scheme code for evaluation -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015, 2021 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 16 ;;; Code: 17 18 (require 'geiser-impl) 19 (require 'geiser-connection) 20 (require 'geiser-syntax) 21 (require 'geiser-log) 22 (require 'geiser-base) 23 24 25 ;;; Plug-able functions: 26 27 (defvar-local geiser-eval--get-module-function nil) 28 29 (defvar geiser-eval--get-impl-module nil) 30 (geiser-impl--register-local-method 31 'geiser-eval--get-impl-module 'find-module '(lambda (&rest args) nil) 32 "Function used to obtain the module for current buffer. It takes 33 an optional argument, for cases where we want to force its 34 value.") 35 36 (defun geiser-eval--get-module (&optional module) 37 (cond (geiser-eval--get-module-function 38 (funcall geiser-eval--get-module-function module)) 39 (geiser-eval--get-impl-module 40 (funcall geiser-eval--get-impl-module module)) 41 (t module))) 42 43 (defvar geiser-eval--geiser-procedure-function nil) 44 (geiser-impl--register-local-method 45 'geiser-eval--geiser-procedure-function 'marshall-procedure 'identity 46 "Function to translate a bare procedure symbol to one executable 47 in the Scheme context. Return NULL for unsupported ones; at the 48 very least, EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be 49 supported. Geiser will also invoke, if defined, the following 50 procedures, always wrapped in EVAL (with the current module as 51 its context): AUTODOC, SYMBOL-DOCUMENTATION, MODULE-EXPORTS, 52 SYMBOL-LOCATION, MODULE-LOCATION, COMPLETIONS, 53 MODULE-COMPLETIONS, MACRO-EXPAND ADD-TO-LOAD-PATH, METHOD, 54 CALLER, CALLEE and NO-VALUES.") 55 56 (defvar geiser-eval--unsupported nil) 57 (geiser-impl--register-local-variable 58 'geiser-eval--unsupported 'unsupported-procedures nil 59 "A list, or function returning a list, of the Geiser procedures 60 not implemented by this Scheme implementation. Possible values 61 include macroexpand, completions, module-completions, find-file, 62 symbol-location, module-location, symbol-documentation, 63 module-exports, autodoc, callers, callees and generic-methods.") 64 65 (defun geiser-eval--supported-p (feat) 66 (or (not geiser-eval--unsupported) 67 (not (memq feat geiser-eval--unsupported)))) 68 69 (defsubst geiser-eval--form (&rest args) 70 (when (not (geiser-eval--supported-p (car args))) 71 (error "Sorry, the %s scheme implementation does not support Geiser's %s" 72 geiser-impl--implementation (car args))) 73 (apply (or geiser-eval--geiser-procedure-function 'ignore) args)) 74 75 76 ;;; Code formatting: 77 78 (defsubst geiser-eval--load-file (file) 79 (geiser-eval--form 'load-file (geiser-eval--scheme-str file))) 80 81 (defsubst geiser-eval--comp-file (file) 82 (geiser-eval--form 'compile-file (geiser-eval--scheme-str file))) 83 84 (defsubst geiser-eval--module (code) 85 (geiser-eval--scheme-str 86 (cond ((or (null code) (eq code :t) (eq code :buffer)) 87 (geiser-eval--get-module)) 88 ((or (eq code :repl) (eq code :f)) :f) 89 (t (geiser-eval--get-module code))))) 90 91 (defsubst geiser-eval--eval (code) 92 (geiser-eval--form 'eval 93 (geiser-eval--module (nth 1 code)) 94 (geiser-eval--scheme-str (nth 0 code)))) 95 96 (defsubst geiser-eval--comp (code) 97 (geiser-eval--form 'compile 98 (geiser-eval--module (nth 1 code)) 99 (geiser-eval--scheme-str (nth 0 code)))) 100 101 (defsubst geiser-eval--ge (proc args) 102 (apply 'geiser-eval--form (cons proc (mapcar 'geiser-eval--scheme-str args)))) 103 104 (defsubst geiser-eval--debug (args) 105 (geiser-eval--ge 'debug args)) 106 107 (defun geiser-eval--scheme-str (code) 108 (cond ((null code) "'()") 109 ((eq code :f) "#f") 110 ((eq code :t) "#t") 111 ((listp code) 112 (cond ((eq (car code) :debug) (geiser-eval--debug (cdr code))) 113 ((eq (car code) :eval) (geiser-eval--eval (cdr code))) 114 ((eq (car code) :comp) (geiser-eval--comp (cdr code))) 115 ((eq (car code) :load-file) 116 (geiser-eval--load-file (cadr code))) 117 ((eq (car code) :comp-file) 118 (geiser-eval--comp-file (cadr code))) 119 ((eq (car code) :module) (geiser-eval--module (cadr code))) 120 ((eq (car code) :ge) (geiser-eval--ge (cadr code) 121 (cddr code))) 122 ((eq (car code) :scm) (cadr code)) 123 (t (concat "(" 124 (mapconcat 'geiser-eval--scheme-str code " ") 125 ")")))) 126 ((symbolp code) (substring-no-properties (format "%s" code))) 127 (t (substring-no-properties (format "%S" code))))) 128 129 130 ;;; Code sending: 131 132 (defvar geiser-eval--default-connection-function nil) 133 134 (defsubst geiser-eval--connection () 135 (and geiser-eval--default-connection-function 136 (funcall geiser-eval--default-connection-function))) 137 138 (defun geiser-eval--log (s) 139 (geiser-log--info "RETORT: %S" s) 140 s) 141 142 (defsubst geiser-eval--code-str (code) 143 (if (stringp code) code (geiser-eval--scheme-str code))) 144 145 (defvar geiser-eval--async-retort nil) 146 (defsubst geiser-eval--send (code cont &optional buffer) 147 (setq geiser-eval--async-retort nil) 148 (geiser-con--send-string (geiser-eval--connection) 149 (geiser-eval--code-str code) 150 (lambda (s) 151 (setq geiser-eval--async-retort (geiser-eval--log s)) 152 (funcall cont s)) 153 buffer)) 154 155 (defun geiser-eval--wait (req timeout) 156 (or (geiser-con--wait req timeout) geiser-eval--async-retort)) 157 158 (defvar geiser-eval--sync-retort nil) 159 (defun geiser-eval--set-sync-retort (s) 160 (setq geiser-eval--sync-retort (geiser-eval--log s))) 161 162 (defun geiser-eval--send/wait (code &optional timeout buffer) 163 (setq geiser-eval--sync-retort nil) 164 (geiser-con--send-string/wait (geiser-eval--connection) 165 (geiser-eval--code-str code) 166 'geiser-eval--set-sync-retort 167 timeout 168 buffer) 169 geiser-eval--sync-retort) 170 171 (defun geiser-eval-interrupt () 172 "Interrupt on-going evaluation, if any." 173 (interactive) 174 (geiser-con--interrupt (geiser-eval--connection))) 175 176 177 ;;; Retort parsing: 178 179 (defsubst geiser-eval--retort-p (ret) 180 (and (listp ret) (or (assoc 'error ret) (assoc 'result ret)))) 181 182 (defsubst geiser-eval--retort-result (ret) 183 (let ((values (cdr (assoc 'result ret)))) 184 (car (geiser-syntax--read-from-string (car values))))) 185 186 (defsubst geiser-eval--send/result (code &optional timeout buffer) 187 (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer))) 188 189 (defun geiser-eval--retort-result-str (ret prefix) 190 (let* ((prefix (or prefix "=> ")) 191 (nlprefix (concat "\n" prefix)) 192 (values (cdr (assoc 'result ret)))) 193 (if values 194 (concat prefix (mapconcat 'identity values nlprefix)) 195 (or prefix "(No value)")))) 196 197 (defsubst geiser-eval--retort-output (ret) 198 (cdr (assq 'output ret))) 199 200 (defsubst geiser-eval--retort-error (ret) 201 (cdr (assq 'error ret))) 202 203 (defsubst geiser-eval--error-key (err) 204 (cdr (assq 'key err))) 205 206 (defsubst geiser-eval--error-subr (err) 207 (cdr (assq 'subr err))) 208 209 (defsubst geiser-eval--error-msg (err) 210 (cdr (assq 'msg err))) 211 212 (defsubst geiser-eval--error-rest (err) 213 (cdr (assq 'rest err))) 214 215 (defun geiser-eval--error-str (err) 216 (let* ((key (geiser-eval--error-key err)) 217 (key-str (if key (format ": %s" key) ":")) 218 (subr (geiser-eval--error-subr err)) 219 (subr-str (if subr (format " (%s):" subr) "")) 220 (msg (geiser-eval--error-msg err)) 221 (msg-str (if msg (format "\n %s" msg) "")) 222 (rest (geiser-eval--error-rest err)) 223 (rest-str (if rest (format "\n %s" rest) ""))) 224 (format "Error%s%s%s%s" subr-str key-str msg-str rest-str))) 225 226 227 228 (provide 'geiser-eval)