diff options
Diffstat (limited to 'elpa/org-9.5.2/ob-scheme.el')
| -rw-r--r-- | elpa/org-9.5.2/ob-scheme.el | 241 |
1 files changed, 241 insertions, 0 deletions
diff --git a/elpa/org-9.5.2/ob-scheme.el b/elpa/org-9.5.2/ob-scheme.el new file mode 100644 index 0000000..f4836b2 --- /dev/null +++ b/elpa/org-9.5.2/ob-scheme.el @@ -0,0 +1,241 @@ +;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*- + +;; Copyright (C) 2010-2021 Free Software Foundation, Inc. + +;; Authors: Eric Schulte +;; Michael Gauland +;; Keywords: literate programming, reproducible research, scheme +;; Homepage: https://orgmode.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Now working with SBCL for both session and external evaluation. +;; +;; This certainly isn't optimally robust, but it seems to be working +;; for the basic use cases. + +;;; Requirements: + +;; - a working scheme implementation +;; (e.g. guile https://www.gnu.org/software/guile/guile.html) +;; +;; - for session based evaluation geiser is required, which is available from +;; ELPA. + +;;; Code: +(require 'ob) +(require 'geiser nil t) +(require 'geiser-impl nil t) +(defvar geiser-repl--repl) ; Defined in geiser-repl.el +(defvar geiser-impl--implementation) ; Defined in geiser-impl.el +(defvar geiser-scheme-implementation) ; Defined in geiser-impl.el +(defvar geiser-default-implementation) ; Defined in geiser-impl.el +(defvar geiser-active-implementations) ; Defined in geiser-impl.el +(defvar geiser-debug-show-debug-p) ; Defined in geiser-debug.el +(defvar geiser-debug-jump-to-debug-p) ; Defined in geiser-debug.el +(defvar geiser-repl-use-other-window) ; Defined in geiser-repl.el +(defvar geiser-repl-window-allow-split) ; Defined in geiser-repl.el + +(declare-function run-geiser "ext:geiser-repl" (impl)) +(declare-function geiser-mode "ext:geiser-mode" ()) +(declare-function geiser-eval-region "ext:geiser-mode" + (start end &optional and-go raw nomsg)) +(declare-function geiser-repl-exit "ext:geiser-repl" (&optional arg)) +(declare-function geiser-eval--retort-output "ext:geiser-eval" (ret)) +(declare-function geiser-eval--retort-result-str "ext:geiser-eval" (ret prefix)) + +(defcustom org-babel-scheme-null-to 'hline + "Replace `null' and empty lists in scheme tables with this before returning." + :group 'org-babel + :version "26.1" + :package-version '(Org . "9.1") + :type 'symbol) + +(defvar org-babel-default-header-args:scheme '() + "Default header arguments for scheme code blocks.") + +(defun org-babel-expand-body:scheme (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((vars (org-babel--get-vars params)) + (prepends (cdr (assq :prologue params))) + (postpends (cdr (assq :epilogue params)))) + (concat (and prepends (concat prepends "\n")) + (if (null vars) body + (format "(let (%s)\n%s\n)" + (mapconcat + (lambda (var) + (format "%S" (print `(,(car var) ',(cdr var))))) + vars + "\n ") + body)) + (and postpends (concat "\n" postpends))))) + + +(defvar org-babel-scheme-repl-map (make-hash-table :test #'equal) + "Map of scheme sessions to session names.") + +(defun org-babel-scheme-cleanse-repl-map () + "Remove dead buffers from the REPL map." + (maphash + (lambda (x y) (unless (buffer-name y) (remhash x org-babel-scheme-repl-map))) + org-babel-scheme-repl-map)) + +(defun org-babel-scheme-get-session-buffer (session-name) + "Look up the scheme buffer for a session; return nil if it doesn't exist." + (org-babel-scheme-cleanse-repl-map) ; Prune dead sessions + (gethash session-name org-babel-scheme-repl-map)) + +(defun org-babel-scheme-set-session-buffer (session-name buffer) + "Record the scheme buffer used for a given session." + (puthash session-name buffer org-babel-scheme-repl-map)) + +(defun org-babel-scheme-get-buffer-impl (buffer) + "Return the scheme implementation geiser associates with the buffer." + (with-current-buffer (set-buffer buffer) + geiser-impl--implementation)) + +(defun org-babel-scheme-get-repl (impl name) + "Switch to a scheme REPL, creating it if it doesn't exist." + (let ((buffer (org-babel-scheme-get-session-buffer name))) + (or buffer + (progn + (run-geiser impl) + (when name + (rename-buffer name t) + (org-babel-scheme-set-session-buffer name (current-buffer))) + (current-buffer))))) + +(defun org-babel-scheme-make-session-name (buffer name impl) + "Generate a name for the session buffer. + +For a named session, the buffer name will be the session name. + +If the session is unnamed (nil), generate a name. + +If the session is `none', use nil for the session name, and +org-babel-scheme-execute-with-geiser will use a temporary session." + (cond ((not name) (concat buffer " " (symbol-name impl) " REPL")) + ((string= name "none") nil) + (name))) + +(defmacro org-babel-scheme-capture-current-message (&rest body) + "Capture current message in both interactive and noninteractive mode." + `(if noninteractive + (let ((original-message (symbol-function 'message)) + (current-message nil)) + (unwind-protect + (progn + (defun message (&rest args) + (setq current-message (apply original-message args))) + ,@body + current-message) + (fset 'message original-message))) + (progn + ,@body + (current-message)))) + +(defun org-babel-scheme-execute-with-geiser (code output impl repl) + "Execute code in specified REPL. +If the REPL doesn't exist, create it using the given scheme +implementation. + +Returns the output of executing the code if the OUTPUT parameter +is true; otherwise returns the last value." + (let ((result nil)) + (with-temp-buffer + (insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl)) + (newline) + (insert code) + (geiser-mode) + (let ((geiser-repl-window-allow-split nil) + (geiser-repl-use-other-window nil)) + (let ((repl-buffer (save-current-buffer + (org-babel-scheme-get-repl impl repl)))) + (when (not (eq impl (org-babel-scheme-get-buffer-impl + (current-buffer)))) + (message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl) + (org-babel-scheme-get-buffer-impl (current-buffer)) + (symbolp (org-babel-scheme-get-buffer-impl + (current-buffer))))) + (setq geiser-repl--repl repl-buffer) + (setq geiser-impl--implementation nil) + (let ((geiser-debug-jump-to-debug-p nil) + (geiser-debug-show-debug-p nil)) + (let ((ret (geiser-eval-region (point-min) (point-max)))) + (setq result (if output + (or (geiser-eval--retort-output ret) + "Geiser Interpreter produced no output") + (geiser-eval--retort-result-str ret ""))))) + (when (not repl) + (save-current-buffer (set-buffer repl-buffer) + (geiser-repl-exit)) + (set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil) + (kill-buffer repl-buffer))))) + result)) + +(defun org-babel-scheme--table-or-string (results) + "Convert RESULTS into an appropriate elisp value. +If the results look like a list or tuple, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (let ((res (org-babel-script-escape results))) + (cond ((listp res) + (mapcar (lambda (el) + (if (or (null el) (eq el 'null)) + org-babel-scheme-null-to + el)) + res)) + (t res)))) + +(defun org-babel-execute:scheme (body params) + "Execute a block of Scheme code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let* ((source-buffer (current-buffer)) + (source-buffer-name (replace-regexp-in-string ;; zap surrounding * + "^ ?\\*\\([^*]+\\)\\*" "\\1" + (buffer-name source-buffer)))) + (save-excursion + (let* ((result-type (cdr (assq :result-type params))) + (impl (or (when (cdr (assq :scheme params)) + (intern (cdr (assq :scheme params)))) + geiser-scheme-implementation + geiser-default-implementation + (car geiser-active-implementations))) + (session (org-babel-scheme-make-session-name + source-buffer-name (cdr (assq :session params)) impl)) + (full-body (org-babel-expand-body:scheme body params)) + (result-params (cdr (assq :result-params params))) + (result + (org-babel-scheme-execute-with-geiser + full-body ; code + (string= result-type "output") ; output? + impl ; implementation + (and (not (string= session "none")) session)))) ; session + (let ((table + (org-babel-reassemble-table + result + (org-babel-pick-name (cdr (assq :colname-names params)) + (cdr (assq :colnames params))) + (org-babel-pick-name (cdr (assq :rowname-names params)) + (cdr (assq :rownames params)))))) + (org-babel-result-cond result-params + result + (org-babel-scheme--table-or-string table))))))) + +(provide 'ob-scheme) + +;;; ob-scheme.el ends here |