ob-scheme.el (11490B)
1 ;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2010-2024 Free Software Foundation, Inc. 4 5 ;; Authors: Eric Schulte 6 ;; Michael Gauland 7 ;; Keywords: literate programming, reproducible research, scheme 8 ;; URL: https://orgmode.org 9 10 ;; This file is part of GNU Emacs. 11 12 ;; GNU Emacs is free software: you can redistribute it and/or modify 13 ;; it under the terms of the GNU General Public License as published by 14 ;; the Free Software Foundation, either version 3 of the License, or 15 ;; (at your option) any later version. 16 17 ;; GNU Emacs is distributed in the hope that it will be useful, 18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 ;; GNU General Public License for more details. 21 22 ;; You should have received a copy of the GNU General Public License 23 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 24 25 ;;; Commentary: 26 27 ;; Now working with SBCL for both session and external evaluation. 28 ;; 29 ;; This certainly isn't optimally robust, but it seems to be working 30 ;; for the basic use cases. 31 32 ;;; Requirements: 33 34 ;; - a working scheme implementation 35 ;; (e.g. guile https://www.gnu.org/software/guile/guile.html) 36 ;; 37 ;; - for session based evaluation geiser is required, which is available from 38 ;; ELPA. 39 40 ;;; Code: 41 42 (require 'org-macs) 43 (org-assert-version) 44 45 (require 'ob) 46 (require 'geiser nil t) 47 (require 'geiser-impl nil t) 48 (defvar geiser-repl--repl) ; Defined in geiser-repl.el 49 (defvar geiser-impl--implementation) ; Defined in geiser-impl.el 50 (defvar geiser-scheme-implementation) ; Defined in geiser-impl.el 51 (defvar geiser-default-implementation) ; Defined in geiser-impl.el 52 (defvar geiser-active-implementations) ; Defined in geiser-impl.el 53 (defvar geiser-debug-show-debug-p) ; Defined in geiser-debug.el 54 (defvar geiser-debug-jump-to-debug-p) ; Defined in geiser-debug.el 55 (defvar geiser-repl-use-other-window) ; Defined in geiser-repl.el 56 (defvar geiser-repl-window-allow-split) ; Defined in geiser-repl.el 57 (declare-function geiser-connect "ext:geiser-repl" (impl &optional host port)) 58 (declare-function run-geiser "ext:geiser-repl" (impl)) 59 (declare-function geiser "ext:geiser-repl" (impl)) 60 (declare-function geiser-mode "ext:geiser-mode" ()) 61 (declare-function geiser-eval-region "ext:geiser-mode" 62 (start end &optional and-go raw nomsg)) 63 (declare-function geiser-eval-region/wait "ext:geiser-mode" 64 (start end &optional timeout)) 65 (declare-function geiser-repl-exit "ext:geiser-repl" (&optional arg)) 66 (declare-function geiser-eval--retort-output "ext:geiser-eval" (ret)) 67 (declare-function geiser-eval--retort-result-str "ext:geiser-eval" (ret prefix)) 68 (declare-function geiser-eval--retort-error "ext:geiser-eval" (ret)) 69 (declare-function geiser-eval--retort-error-msg "ext:geiser-eval" (err)) 70 (declare-function geiser-eval--error-msg "ext:geiser-eval" (err)) 71 72 (defcustom org-babel-scheme-null-to 'hline 73 "Replace `null' and empty lists in scheme tables with this before returning." 74 :group 'org-babel 75 :version "26.1" 76 :package-version '(Org . "9.1") 77 :type 'symbol) 78 79 (defvar org-babel-default-header-args:scheme '() 80 "Default header arguments for scheme code blocks.") 81 (defconst org-babel-header-args:scheme '((host . :any) 82 (port . :any)) 83 "Header arguments supported in Scheme.") 84 85 (defun org-babel-scheme-expand-header-arg-vars (vars) 86 "Expand :var header arguments given as VARS." 87 (mapconcat 88 (lambda (var) 89 (format "(define %S %S)" (car var) (cdr var))) 90 vars 91 "\n")) 92 93 (defun org-babel-expand-body:scheme (body params) 94 "Expand BODY according to PARAMS, return the expanded body." 95 (let ((vars (org-babel--get-vars params)) 96 (prepends (cdr (assq :prologue params))) 97 (postpends (cdr (assq :epilogue params)))) 98 (concat (and prepends (concat prepends "\n")) 99 (if (null vars) body 100 (concat (org-babel-scheme-expand-header-arg-vars vars) "\n" body)) 101 (and postpends (concat "\n" postpends))))) 102 103 104 (defvar org-babel-scheme-repl-map (make-hash-table :test #'equal) 105 "Map of scheme sessions to session names.") 106 107 (defun org-babel-scheme-cleanse-repl-map () 108 "Remove dead buffers from the REPL map." 109 (maphash 110 (lambda (x y) (unless (buffer-name y) (remhash x org-babel-scheme-repl-map))) 111 org-babel-scheme-repl-map)) 112 113 (defun org-babel-scheme-get-session-buffer (session-name) 114 "Look up the scheme buffer for a session; return nil if it doesn't exist." 115 (org-babel-scheme-cleanse-repl-map) ; Prune dead sessions 116 (gethash session-name org-babel-scheme-repl-map)) 117 118 (defun org-babel-scheme-set-session-buffer (session-name buffer) 119 "Record the scheme buffer used for a given session." 120 (puthash session-name buffer org-babel-scheme-repl-map)) 121 122 (defun org-babel-scheme-get-buffer-impl (buffer) 123 "Return the scheme implementation geiser associates with the buffer." 124 (with-current-buffer (set-buffer buffer) 125 geiser-impl--implementation)) 126 127 (defun org-babel-scheme-get-repl (impl name &optional host port) 128 "Switch to a Scheme REPL, creating it if it doesn't exist. 129 130 If the variables HOST and PORT are set, connect to the running Scheme REPL." 131 (let ((buffer (org-babel-scheme-get-session-buffer name))) 132 (or buffer 133 (progn 134 (if (fboundp 'geiser) 135 (if (and host port) 136 (geiser-connect impl host port) 137 (geiser impl)) 138 ;; Obsolete since Geiser 0.26. 139 (run-geiser impl)) 140 (when name 141 (rename-buffer name t) 142 (org-babel-scheme-set-session-buffer name (current-buffer))) 143 (current-buffer))))) 144 145 (defun org-babel-scheme-make-session-name (buffer name impl) 146 "Generate a NAME for the session BUFFER. 147 148 For a named session, the buffer name will be the session name. 149 150 If the session is unnamed (nil), generate a name. 151 152 If the session is `none', use nil for the session name, and 153 `org-babel-scheme-execute-with-geiser' will use a temporary session." 154 (cond ((not name) (concat buffer " " (symbol-name impl) " REPL")) 155 ((string= name "none") nil) 156 (name))) 157 158 (defmacro org-babel-scheme-capture-current-message (&rest body) 159 "Capture current message in both interactive and noninteractive mode." 160 `(if noninteractive 161 (let ((original-message (symbol-function 'message)) 162 (current-message nil)) 163 (unwind-protect 164 (progn 165 (defun message (&rest args) 166 (setq current-message (apply original-message args))) 167 ,@body 168 current-message) 169 (fset 'message original-message))) 170 (progn 171 ,@body 172 (current-message)))) 173 174 (defun org-babel-scheme-execute-with-geiser (code output impl repl &optional host port) 175 "Execute code in specified REPL. 176 If the REPL doesn't exist, create it using the given scheme 177 implementation. 178 179 Returns the output of executing the code if the OUTPUT parameter 180 is true; otherwise returns the last value." 181 (let ((result nil)) 182 (with-temp-buffer 183 (insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl)) 184 (newline) 185 (let ((beg (point))) 186 (insert code) 187 (geiser-mode) 188 (let ((geiser-repl-window-allow-split nil) 189 (geiser-repl-use-other-window nil)) 190 (let ((repl-buffer (save-current-buffer 191 (org-babel-scheme-get-repl impl repl host port)))) 192 (when (not (eq impl (org-babel-scheme-get-buffer-impl 193 (current-buffer)))) 194 (message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl) 195 (org-babel-scheme-get-buffer-impl (current-buffer)) 196 (symbolp (org-babel-scheme-get-buffer-impl 197 (current-buffer))))) 198 (setq geiser-repl--repl repl-buffer) 199 (setq geiser-impl--implementation nil) 200 (let ((geiser-debug-jump-to-debug-p nil) 201 (geiser-debug-show-debug-p nil)) 202 ;; `geiser-eval-region/wait' was introduced to await the 203 ;; result of async evaluation in geiser version 0.22. 204 (let ((ret (funcall (if (fboundp 'geiser-eval-region/wait) 205 #'geiser-eval-region/wait 206 #'geiser-eval-region) 207 ;; Do not include top comment into evaluation. 208 ;; Apparently, mit-scheme has 209 ;; problems with the top comment we add: 210 ;; "Unexpected read restart on: #[textual-i/o-port 27 for console]" 211 beg 212 (point-max)))) 213 (let ((err (geiser-eval--retort-error ret))) 214 (setq result (cond 215 (output 216 (or (geiser-eval--retort-output ret) 217 "Geiser Interpreter produced no output")) 218 (err nil) 219 (t (geiser-eval--retort-result-str ret "")))) 220 (when (not repl) 221 (save-current-buffer (set-buffer repl-buffer) 222 (geiser-repl-exit)) 223 (set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil) 224 (kill-buffer repl-buffer)) 225 (when err 226 (let ((msg (geiser-eval--error-msg err))) 227 (org-babel-eval-error-notify 228 nil 229 (concat (if (listp msg) (car msg) msg) "\n"))))))))))) 230 result)) 231 232 (defun org-babel-scheme--table-or-string (results) 233 "Convert RESULTS into an appropriate elisp value. 234 If the results look like a list or tuple, then convert them into an 235 Emacs-lisp table, otherwise return the results as a string." 236 (let ((res (and results (org-babel-script-escape results)))) 237 (cond ((listp res) 238 (mapcar (lambda (el) 239 (if (or (null el) (eq el 'null)) 240 org-babel-scheme-null-to 241 el)) 242 res)) 243 (t res)))) 244 245 (defun org-babel-execute:scheme (body params) 246 "Execute a block of Scheme code with org-babel. 247 This function is called by `org-babel-execute-src-block'." 248 (let* ((source-buffer (current-buffer)) 249 (source-buffer-name (replace-regexp-in-string ;; zap surrounding * 250 "^ ?\\*\\([^*]+\\)\\*" "\\1" 251 (buffer-name source-buffer)))) 252 (save-excursion 253 (let* ((result-type (cdr (assq :result-type params))) 254 (impl (or (when (cdr (assq :scheme params)) 255 (intern (cdr (assq :scheme params)))) 256 geiser-scheme-implementation 257 geiser-default-implementation 258 (car geiser-active-implementations))) 259 (host (cdr (assq :host params))) 260 (port (cdr (assq :port params))) 261 (session (org-babel-scheme-make-session-name 262 source-buffer-name (cdr (assq :session params)) impl)) 263 (full-body (org-babel-expand-body:scheme body params)) 264 (result-params (cdr (assq :result-params params))) 265 (result 266 (org-babel-scheme-execute-with-geiser 267 full-body ; code 268 (string= result-type "output") ; output? 269 impl ; implementation 270 (and (not (string= session "none")) session) ; session 271 host ; REPL host 272 port))) ; REPL port 273 (let ((table 274 (org-babel-reassemble-table 275 result 276 (org-babel-pick-name (cdr (assq :colname-names params)) 277 (cdr (assq :colnames params))) 278 (org-babel-pick-name (cdr (assq :rowname-names params)) 279 (cdr (assq :rownames params)))))) 280 (org-babel-result-cond result-params 281 result 282 (org-babel-scheme--table-or-string table))))))) 283 284 (provide 'ob-scheme) 285 286 ;;; ob-scheme.el ends here