123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233 |
- ;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*-
- ;; Copyright (C) 2010-2018 Free Software Foundation, Inc.
- ;; Authors: Eric Schulte
- ;; Michael Gauland
- ;; Keywords: literate programming, reproducible research, scheme
- ;; Homepage: http://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-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))))
- (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)))))
- (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)
- "Returns 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)
- (if name
- (progn
- (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
- (geiser-eval--retort-output ret)
- (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-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
- (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-scheme--table-or-string table))))))
- (provide 'ob-scheme)
- ;;; ob-scheme.el ends here
|