Commit | Line | Data |
---|---|---|
afe98dfa CD |
1 | ;;; ob-scheme.el --- org-babel functions for Scheme |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2010-2014 Free Software Foundation, Inc. |
afe98dfa | 4 | |
271672fa | 5 | ;; Authors: Eric Schulte, Michael Gauland |
afe98dfa CD |
6 | ;; Keywords: literate programming, reproducible research, scheme |
7 | ;; Homepage: http://orgmode.org | |
afe98dfa | 8 | |
c7557a0f | 9 | ;; This file is part of GNU Emacs. |
afe98dfa | 10 | |
c7557a0f | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
afe98dfa | 12 | ;; it under the terms of the GNU General Public License as published by |
c7557a0f GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
afe98dfa CD |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
c7557a0f | 20 | |
afe98dfa | 21 | ;; You should have received a copy of the GNU General Public License |
c7557a0f | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
afe98dfa CD |
23 | |
24 | ;;; Commentary: | |
25 | ||
26 | ;; Now working with SBCL for both session and external evaluation. | |
27 | ;; | |
28 | ;; This certainly isn't optimally robust, but it seems to be working | |
29 | ;; for the basic use cases. | |
30 | ||
31 | ;;; Requirements: | |
32 | ||
33 | ;; - a working scheme implementation | |
34 | ;; (e.g. guile http://www.gnu.org/software/guile/guile.html) | |
c7557a0f | 35 | ;; |
271672fa BG |
36 | ;; - for session based evaluation geiser is required, which is available from |
37 | ;; ELPA. | |
afe98dfa CD |
38 | |
39 | ;;; Code: | |
40 | (require 'ob) | |
271672fa BG |
41 | (require 'geiser nil t) |
42 | (defvar geiser-repl--repl) ; Defined in geiser-repl.el | |
43 | (defvar geiser-impl--implementation) ; Defined in geiser-impl.el | |
44 | (defvar geiser-default-implementation) ; Defined in geiser-impl.el | |
45 | (defvar geiser-active-implementations) ; Defined in geiser-impl.el | |
afe98dfa | 46 | |
271672fa BG |
47 | (declare-function run-geiser "geiser-repl" (impl)) |
48 | (declare-function geiser-mode "geiser-mode" ()) | |
49 | (declare-function geiser-eval-region "geiser-mode" (start end &optional and-go raw nomsg)) | |
50 | (declare-function geiser-repl-exit "geiser-repl" (&optional arg)) | |
afe98dfa CD |
51 | |
52 | (defvar org-babel-default-header-args:scheme '() | |
53 | "Default header arguments for scheme code blocks.") | |
54 | ||
afe98dfa CD |
55 | (defun org-babel-expand-body:scheme (body params) |
56 | "Expand BODY according to PARAMS, return the expanded body." | |
57 | (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) | |
58 | (if (> (length vars) 0) | |
59 | (concat "(let (" | |
60 | (mapconcat | |
61 | (lambda (var) (format "%S" (print `(,(car var) ',(cdr var))))) | |
62 | vars "\n ") | |
63 | ")\n" body ")") | |
64 | body))) | |
65 | ||
271672fa BG |
66 | |
67 | (defvar org-babel-scheme-repl-map (make-hash-table :test 'equal) | |
68 | "Map of scheme sessions to session names.") | |
69 | ||
70 | (defun org-babel-scheme-cleanse-repl-map () | |
71 | "Remove dead buffers from the REPL map." | |
72 | (maphash | |
73 | (lambda (x y) | |
74 | (when (not (buffer-name y)) | |
75 | (remhash x org-babel-scheme-repl-map))) | |
76 | org-babel-scheme-repl-map)) | |
77 | ||
78 | (defun org-babel-scheme-get-session-buffer (session-name) | |
79 | "Look up the scheme buffer for a session; return nil if it doesn't exist." | |
80 | (org-babel-scheme-cleanse-repl-map) ; Prune dead sessions | |
81 | (gethash session-name org-babel-scheme-repl-map)) | |
82 | ||
83 | (defun org-babel-scheme-set-session-buffer (session-name buffer) | |
84 | "Record the scheme buffer used for a given session." | |
85 | (puthash session-name buffer org-babel-scheme-repl-map)) | |
86 | ||
87 | (defun org-babel-scheme-get-buffer-impl (buffer) | |
88 | "Returns the scheme implementation geiser associates with the buffer." | |
89 | (with-current-buffer (set-buffer buffer) | |
90 | geiser-impl--implementation)) | |
91 | ||
92 | (defun org-babel-scheme-get-repl (impl name) | |
93 | "Switch to a scheme REPL, creating it if it doesn't exist:" | |
94 | (let ((buffer (org-babel-scheme-get-session-buffer name))) | |
95 | (or buffer | |
96 | (progn | |
97 | (run-geiser impl) | |
98 | (if name | |
99 | (progn | |
100 | (rename-buffer name t) | |
101 | (org-babel-scheme-set-session-buffer name (current-buffer)))) | |
102 | (current-buffer))))) | |
103 | ||
104 | (defun org-babel-scheme-make-session-name (buffer name impl) | |
105 | "Generate a name for the session buffer. | |
106 | ||
107 | For a named session, the buffer name will be the session name. | |
108 | ||
109 | If the session is unnamed (nil), generate a name. | |
110 | ||
111 | If the session is 'none', use nil for the session name, and | |
112 | org-babel-scheme-execute-with-geiser will use a temporary session." | |
113 | (let ((result | |
114 | (cond ((not name) | |
115 | (concat buffer " " (symbol-name impl) " REPL")) | |
116 | ((string= name "none") nil) | |
117 | (name)))) | |
118 | result)) | |
119 | ||
120 | (defun org-babel-scheme-execute-with-geiser (code output impl repl) | |
121 | "Execute code in specified REPL. If the REPL doesn't exist, create it | |
122 | using the given scheme implementation. | |
123 | ||
124 | Returns the output of executing the code if the output parameter | |
125 | is true; otherwise returns the last value." | |
126 | (let ((result nil)) | |
127 | (with-temp-buffer | |
128 | (insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl)) | |
129 | (newline) | |
130 | (insert (if output | |
131 | (format "(with-output-to-string (lambda () %s))" code) | |
132 | code)) | |
133 | (geiser-mode) | |
134 | (let ((repl-buffer (save-current-buffer | |
135 | (org-babel-scheme-get-repl impl repl)))) | |
136 | (when (not (eq impl (org-babel-scheme-get-buffer-impl | |
137 | (current-buffer)))) | |
138 | (message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl) | |
139 | (org-babel-scheme-get-buffer-impl (current-buffer)) | |
140 | (symbolp (org-babel-scheme-get-buffer-impl | |
141 | (current-buffer))))) | |
142 | (setq geiser-repl--repl repl-buffer) | |
143 | (setq geiser-impl--implementation nil) | |
144 | (geiser-eval-region (point-min) (point-max)) | |
145 | (setq result | |
146 | (if (equal (substring (current-message) 0 3) "=> ") | |
147 | (replace-regexp-in-string "^=> " "" (current-message)) | |
148 | "\"An error occurred.\"")) | |
149 | (when (not repl) | |
150 | (save-current-buffer (set-buffer repl-buffer) | |
151 | (geiser-repl-exit)) | |
152 | (set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil) | |
153 | (kill-buffer repl-buffer)) | |
154 | (setq result (if (or (string= result "#<void>") | |
155 | (string= result "#<unspecified>")) | |
156 | nil | |
157 | (read result))))) | |
158 | result)) | |
159 | ||
afe98dfa CD |
160 | (defun org-babel-execute:scheme (body params) |
161 | "Execute a block of Scheme code with org-babel. | |
162 | This function is called by `org-babel-execute-src-block'" | |
271672fa BG |
163 | (let* ((source-buffer (current-buffer)) |
164 | (source-buffer-name (replace-regexp-in-string ;; zap surrounding * | |
165 | "^ ?\\*\\([^*]+\\)\\*" "\\1" | |
166 | (buffer-name source-buffer)))) | |
167 | (save-excursion | |
168 | (org-babel-reassemble-table | |
169 | (let* ((result-type (cdr (assoc :result-type params))) | |
170 | (impl (or (when (cdr (assoc :scheme params)) | |
171 | (intern (cdr (assoc :scheme params)))) | |
172 | geiser-default-implementation | |
173 | (car geiser-active-implementations))) | |
174 | (session (org-babel-scheme-make-session-name | |
175 | source-buffer-name (cdr (assoc :session params)) impl)) | |
176 | (full-body (org-babel-expand-body:scheme body params))) | |
177 | (org-babel-scheme-execute-with-geiser | |
178 | full-body ; code | |
179 | (string= result-type "output") ; output? | |
180 | impl ; implementation | |
181 | (and (not (string= session "none")) session))) ; session | |
182 | (org-babel-pick-name (cdr (assoc :colname-names params)) | |
183 | (cdr (assoc :colnames params))) | |
184 | (org-babel-pick-name (cdr (assoc :rowname-names params)) | |
185 | (cdr (assoc :rownames params))))))) | |
afe98dfa CD |
186 | |
187 | (provide 'ob-scheme) | |
188 | ||
afe98dfa | 189 | ;;; ob-scheme.el ends here |