ob-scheme.el (9879B)
1 ;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2010-2023 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 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 69 (defcustom org-babel-scheme-null-to 'hline 70 "Replace `null' and empty lists in scheme tables with this before returning." 71 :group 'org-babel 72 :version "26.1" 73 :package-version '(Org . "9.1") 74 :type 'symbol) 75 76 (defvar org-babel-default-header-args:scheme '() 77 "Default header arguments for scheme code blocks.") 78 79 (defun org-babel-expand-body:scheme (body params) 80 "Expand BODY according to PARAMS, return the expanded body." 81 (let ((vars (org-babel--get-vars params)) 82 (prepends (cdr (assq :prologue params))) 83 (postpends (cdr (assq :epilogue params)))) 84 (concat (and prepends (concat prepends "\n")) 85 (if (null vars) body 86 (format "(let (%s)\n%s\n)" 87 (mapconcat 88 (lambda (var) 89 (format "%S" (print `(,(car var) ',(cdr var))))) 90 vars 91 "\n ") 92 body)) 93 (and postpends (concat "\n" postpends))))) 94 95 96 (defvar org-babel-scheme-repl-map (make-hash-table :test #'equal) 97 "Map of scheme sessions to session names.") 98 99 (defun org-babel-scheme-cleanse-repl-map () 100 "Remove dead buffers from the REPL map." 101 (maphash 102 (lambda (x y) (unless (buffer-name y) (remhash x org-babel-scheme-repl-map))) 103 org-babel-scheme-repl-map)) 104 105 (defun org-babel-scheme-get-session-buffer (session-name) 106 "Look up the scheme buffer for a session; return nil if it doesn't exist." 107 (org-babel-scheme-cleanse-repl-map) ; Prune dead sessions 108 (gethash session-name org-babel-scheme-repl-map)) 109 110 (defun org-babel-scheme-set-session-buffer (session-name buffer) 111 "Record the scheme buffer used for a given session." 112 (puthash session-name buffer org-babel-scheme-repl-map)) 113 114 (defun org-babel-scheme-get-buffer-impl (buffer) 115 "Return the scheme implementation geiser associates with the buffer." 116 (with-current-buffer (set-buffer buffer) 117 geiser-impl--implementation)) 118 119 (defun org-babel-scheme-get-repl (impl name) 120 "Switch to a scheme REPL, creating it if it doesn't exist." 121 (let ((buffer (org-babel-scheme-get-session-buffer name))) 122 (or buffer 123 (progn 124 (if (fboundp 'geiser) 125 (geiser impl) 126 ;; Obsolete since Geiser 0.26. 127 (run-geiser impl)) 128 (when name 129 (rename-buffer name t) 130 (org-babel-scheme-set-session-buffer name (current-buffer))) 131 (current-buffer))))) 132 133 (defun org-babel-scheme-make-session-name (buffer name impl) 134 "Generate a name for the session buffer. 135 136 For a named session, the buffer name will be the session name. 137 138 If the session is unnamed (nil), generate a name. 139 140 If the session is `none', use nil for the session name, and 141 org-babel-scheme-execute-with-geiser will use a temporary session." 142 (cond ((not name) (concat buffer " " (symbol-name impl) " REPL")) 143 ((string= name "none") nil) 144 (name))) 145 146 (defmacro org-babel-scheme-capture-current-message (&rest body) 147 "Capture current message in both interactive and noninteractive mode." 148 `(if noninteractive 149 (let ((original-message (symbol-function 'message)) 150 (current-message nil)) 151 (unwind-protect 152 (progn 153 (defun message (&rest args) 154 (setq current-message (apply original-message args))) 155 ,@body 156 current-message) 157 (fset 'message original-message))) 158 (progn 159 ,@body 160 (current-message)))) 161 162 (defun org-babel-scheme-execute-with-geiser (code output impl repl) 163 "Execute code in specified REPL. 164 If the REPL doesn't exist, create it using the given scheme 165 implementation. 166 167 Returns the output of executing the code if the OUTPUT parameter 168 is true; otherwise returns the last value." 169 (let ((result nil)) 170 (with-temp-buffer 171 (insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl)) 172 (newline) 173 (insert code) 174 (geiser-mode) 175 (let ((geiser-repl-window-allow-split nil) 176 (geiser-repl-use-other-window nil)) 177 (let ((repl-buffer (save-current-buffer 178 (org-babel-scheme-get-repl impl repl)))) 179 (when (not (eq impl (org-babel-scheme-get-buffer-impl 180 (current-buffer)))) 181 (message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl) 182 (org-babel-scheme-get-buffer-impl (current-buffer)) 183 (symbolp (org-babel-scheme-get-buffer-impl 184 (current-buffer))))) 185 (setq geiser-repl--repl repl-buffer) 186 (setq geiser-impl--implementation nil) 187 (let ((geiser-debug-jump-to-debug-p nil) 188 (geiser-debug-show-debug-p nil)) 189 ;; `geiser-eval-region/wait' was introduced to await the 190 ;; result of async evaluation in geiser version 0.22. 191 (let ((ret (funcall (if (fboundp 'geiser-eval-region/wait) 192 #'geiser-eval-region/wait 193 #'geiser-eval-region) 194 (point-min) 195 (point-max)))) 196 (setq result (if output 197 (or (geiser-eval--retort-output ret) 198 "Geiser Interpreter produced no output") 199 (geiser-eval--retort-result-str ret ""))))) 200 (when (not repl) 201 (save-current-buffer (set-buffer repl-buffer) 202 (geiser-repl-exit)) 203 (set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil) 204 (kill-buffer repl-buffer))))) 205 result)) 206 207 (defun org-babel-scheme--table-or-string (results) 208 "Convert RESULTS into an appropriate elisp value. 209 If the results look like a list or tuple, then convert them into an 210 Emacs-lisp table, otherwise return the results as a string." 211 (let ((res (org-babel-script-escape results))) 212 (cond ((listp res) 213 (mapcar (lambda (el) 214 (if (or (null el) (eq el 'null)) 215 org-babel-scheme-null-to 216 el)) 217 res)) 218 (t res)))) 219 220 (defun org-babel-execute:scheme (body params) 221 "Execute a block of Scheme code with org-babel. 222 This function is called by `org-babel-execute-src-block'." 223 (let* ((source-buffer (current-buffer)) 224 (source-buffer-name (replace-regexp-in-string ;; zap surrounding * 225 "^ ?\\*\\([^*]+\\)\\*" "\\1" 226 (buffer-name source-buffer)))) 227 (save-excursion 228 (let* ((result-type (cdr (assq :result-type params))) 229 (impl (or (when (cdr (assq :scheme params)) 230 (intern (cdr (assq :scheme params)))) 231 geiser-scheme-implementation 232 geiser-default-implementation 233 (car geiser-active-implementations))) 234 (session (org-babel-scheme-make-session-name 235 source-buffer-name (cdr (assq :session params)) impl)) 236 (full-body (org-babel-expand-body:scheme body params)) 237 (result-params (cdr (assq :result-params params))) 238 (result 239 (org-babel-scheme-execute-with-geiser 240 full-body ; code 241 (string= result-type "output") ; output? 242 impl ; implementation 243 (and (not (string= session "none")) session)))) ; session 244 (let ((table 245 (org-babel-reassemble-table 246 result 247 (org-babel-pick-name (cdr (assq :colname-names params)) 248 (cdr (assq :colnames params))) 249 (org-babel-pick-name (cdr (assq :rowname-names params)) 250 (cdr (assq :rownames params)))))) 251 (org-babel-result-cond result-params 252 result 253 (org-babel-scheme--table-or-string table))))))) 254 255 (provide 'ob-scheme) 256 257 ;;; ob-scheme.el ends here