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