* [PATCH] Babel support for scheme using geiser
@ 2013-01-04 19:18 Michael Gauland
2013-01-05 14:42 ` Bastien
0 siblings, 1 reply; 6+ messages in thread
From: Michael Gauland @ 2013-01-04 19:18 UTC (permalink / raw)
To: emacs-orgmode Org-Mode
[-- Attachment #1.1: Type: text/plain, Size: 394 bytes --]
Babel: User geiser for scheme interactions
* lisp/ob-scheme.el Major rewrite to support geiser
This patch uses geiser to execute scheme blocks. Most features of babel
are tested and demonstrated in the attached org file.
Note that because ":results output" and ":var" blocks are wrapped before
being passed to scheme, "(define...)" will generate an error in such blocks.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-Modify-ob-scheme.el-to-use-geiser.patch --]
[-- Type: text/x-diff; name="0001-Modify-ob-scheme.el-to-use-geiser.patch", Size: 9331 bytes --]
From 655d0c1e870d8957974961c8bfc989a75096c60a Mon Sep 17 00:00:00 2001
From: Michael Gauland <mike_gauland@stanfordalumni.org>
Date: Sat, 5 Jan 2013 08:03:19 +1300
Subject: [PATCH] Modify ob-scheme.el to use geiser.
---
lisp/ob-scheme.el | 198 ++++++++++++++++++++++++++++++++--------------------
1 files changed, 122 insertions(+), 76 deletions(-)
diff --git a/lisp/ob-scheme.el b/lisp/ob-scheme.el
index 74e9a94..9e39c72 100644
--- a/lisp/ob-scheme.el
+++ b/lisp/ob-scheme.el
@@ -1,8 +1,8 @@
;;; ob-scheme.el --- org-babel functions for Scheme
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
-;; Author: Eric Schulte
+;; Authors: Eric Schulte, Michael Gauland
;; Keywords: literate programming, reproducible research, scheme
;; Homepage: http://orgmode.org
@@ -33,27 +33,16 @@
;; - a working scheme implementation
;; (e.g. guile http://www.gnu.org/software/guile/guile.html)
;;
-;; - for session based evaluation cmuscheme.el is required which is
-;; included in Emacs
+;; - for session based evaluation geiser is required, which is available from
+;; ELPA.
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
-
-(declare-function run-scheme "ext:cmuscheme" (cmd))
+(load-library "geiser-impl")
(defvar org-babel-default-header-args:scheme '()
"Default header arguments for scheme code blocks.")
-(defvar org-babel-scheme-eoe "org-babel-scheme-eoe"
- "String to indicate that evaluation has completed.")
-
-(defcustom org-babel-scheme-cmd "guile"
- "Name of command used to evaluate scheme blocks."
- :group 'org-babel
- :version "24.1"
- :type 'string)
-
(defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
@@ -65,70 +54,127 @@
")\n" body ")")
body)))
-(defvar scheme-program-name)
+
+(defvar org-babel-scheme-repl-map (make-hash-table :test 'equal)
+ "Map of scheme sessions to session names.")
+
+(defun cleanse-org-babel-scheme-repl-map ()
+ "Remove dead buffers from the REPL map."
+ (maphash
+ (lambda (x y)
+ (when (not (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."
+ (cleanse-org-babel-scheme-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."
+ (let ((result
+ (cond ((not name)
+ (concat buffer " " (symbol-name impl) " REPL"))
+ ((string= name "none") nil)
+ (name))))
+ result))
+
+(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 (if output
+ (format "(with-output-to-string (lambda () %s))" code)
+ code)
+ )
+ (geiser-mode)
+ (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)
+ (geiser-eval-region (point-min) (point-max))
+ (setq result
+ (if (equal (substring (current-message) 0 3) "=> ")
+ (replace-regexp-in-string "^=> " "" (current-message))
+ "\"An error occurred.\""))
+ (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))
+ (setq result (if (or (string= result "#<void>")
+ (string= result "#<unspecified>"))
+ nil
+ (read result)))))
+ result
+ ))
+
(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* ((result-type (cdr (assoc :result-type params)))
- (org-babel-scheme-cmd (or (cdr (assoc :scheme params))
- org-babel-scheme-cmd))
- (full-body (org-babel-expand-body:scheme body params)))
- (read
- (if (not (string= (cdr (assoc :session params)) "none"))
- ;; session evaluation
- (let ((session (org-babel-prep-session:scheme
- (cdr (assoc :session params)) params)))
- (org-babel-comint-with-output
- (session (format "%S" org-babel-scheme-eoe) t body)
- (mapc
- (lambda (line)
- (insert (org-babel-chomp line)) (comint-send-input nil t))
- (list body (format "%S" org-babel-scheme-eoe)))))
- ;; external evaluation
- (let ((script-file (org-babel-temp-file "scheme-script-")))
- (with-temp-file script-file
- (insert
- ;; return the value or the output
- (if (string= result-type "value")
- (format "(display %s)" full-body)
- full-body)))
- (org-babel-eval
- (format "%s %s" org-babel-scheme-cmd
- (org-babel-process-file-name script-file)) ""))))))
-
-(defun org-babel-prep-session:scheme (session params)
- "Prepare SESSION according to the header arguments specified in PARAMS."
- (let* ((session (org-babel-scheme-initiate-session session))
- (vars (mapcar #'cdr (org-babel-get-header params :var)))
- (var-lines
- (mapcar
- (lambda (var) (format "%S" (print `(define ,(car var) ',(cdr var)))))
- vars)))
- (when session
- (org-babel-comint-in-buffer session
- (sit-for .5) (goto-char (point-max))
- (mapc (lambda (var)
- (insert var) (comint-send-input nil t)
- (org-babel-comint-wait-for-output session)
- (sit-for .1) (goto-char (point-max))) var-lines)))
- session))
-
-(defun org-babel-scheme-initiate-session (&optional session)
- "If there is not a current inferior-process-buffer in SESSION
-then create. Return the initialized session."
- (require 'cmuscheme)
- (unless (string= session "none")
- (let ((session-buffer (save-window-excursion
- (run-scheme org-babel-scheme-cmd)
- (rename-buffer session)
- (current-buffer))))
- (if (org-babel-comint-buffer-livep session-buffer)
- (progn (sit-for .25) session-buffer)
- (sit-for .5)
- (org-babel-scheme-initiate-session session)))))
+ (let* ((source-buffer (current-buffer))
+ (source-buffer-name (replace-regexp-in-string ;; zap surrounding *
+ "^ ?\\*\\([^*]+\\)\\*" "\\1" (buffer-name source-buffer))))
+ (save-excursion
+ (org-babel-reassemble-table
+ (let* ((result-type (cdr (assoc :result-type params)))
+ (impl (or (when (cdr (assoc :scheme params))
+ (intern (cdr (assoc :scheme params))))
+ geiser-default-implementation
+ (car geiser-active-implementations)))
+ (session (org-babel-scheme-make-session-name source-buffer-name (cdr (assoc :session params)) impl))
+ (full-body (org-babel-expand-body:scheme body params)))
+ (org-babel-scheme-execute-with-geiser full-body ; code
+ (string= result-type "output") ; output?
+ impl ; implementation
+ (and (not (string= session "none")) session)); session
+ )
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colnames params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rownames params)))))))
+
(provide 'ob-scheme)
-
-
;;; ob-scheme.el ends here
--
1.7.2.5
[-- Attachment #1.3: ob-scheme_test.org --]
[-- Type: text/plain, Size: 11492 bytes --]
#+TITLE: ob-scheme tests
#+AUTHOR: Michael Gauland
#+EMAIL: mikelygee@no8wireless.co.nz
#+DATE: 2012-12-10 Mon
#+DESCRIPTION:
#+KEYWORDS:
#+LANGUAGE: en
#+OPTIONS: H:3 num:nil toc:nil \n:nil @:t ::t |:t ^:{} -:t f:t *:t <:t
#+OPTIONS: TeX:t LaTeX:t skip:nil d:nil todo:t pri:nil tags:not-in-toc
#+INFOJS_OPT: view:nil toc:nil ltoc:t mouse:underline buttons:0 path:http://orgmode.org/org-info.js
#+EXPORT_SELECT_TAGS: export
#+EXPORT_EXCLUDE_TAGS: noexport
#+LINK_UP:
#+LINK_HOME:
#+XSLT:
#+LATEX_HEADER: \lstset{keywordstyle=\color{blue}\bfseries}
#+LATEX_HEADER: \lstset{frame=shadowbox}
#+LATEX_HEADER: \lstset{basicstyle=\ttfamily}
#+LATEX_HEADER: \definecolor{mygray}{gray}{0.8}
#+LATEX_HEADER: \lstset{rulesepcolor=\color{mygray}}
#+LATEX_HEADER: \lstdefinelanguage{scheme}{rulesepcolor=\color{mygray},frameround=ffff,backgroundcolor=\color{white}}
#+LATEX_HEADER: \lstdefinelanguage{Lisp}{rulesepcolor=\color{mygray},frameround=ffff,backgroundcolor=\color{white}}
#+LATEX_HEADER: \lstdefinelanguage{fundamental}{rulesepcolor=\color{blue},frameround=tttt,backgroundcolor=\color{mygray}}
#+PROPERTY: exports both
#+PROPERTY: wrap SRC fundamental
* Implementation Selection
These tests exercise the values that determine which scheme implementation is run:
+ The =:scheme= property
+ =geiser-default-implementation=
+ The first value of =geiser-active-implementations=
These variables currently have the values shown below. They will be changed
during these tests, and restored afterwards.
#+BEGIN_SRC emacs-lisp :wrap :exports results
(list (list "Variable" "Value")
(list "org-babel-default-header-args:scheme"
org-babel-default-header-args:scheme)
(list "geiser-default-implementation" geiser-default-implementation)
(list "geiser-active-implementations" geiser-active-implementations))
#+END_SRC
#+RESULTS:
| Variable | Value |
| org-babel-default-header-args:scheme | ((:scheme . racket)) |
| geiser-default-implementation | nil |
| geiser-active-implementations | (guile racket) |
# Record the version numbers of the scheme interpreters for reference:
#+BEGIN_SRC emacs-lisp :wrap :exports results :results output
(setq guile-version nil)
(setq racket-version nil)
(let ((get-version
(lambda (binary)
(with-temp-buffer
(shell-command
(concat "\"" binary "\""
" --version")
(current-buffer))
(goto-char (point-min))
(search-forward-regexp "[0-9]\\(\.[0-9]+\\)+")
(buffer-substring (match-beginning 0) (match-end 0))))))
(setq guile-version (apply get-version (list geiser-guile-binary)))
(setq racket-version (apply get-version (list geiser-racket-binary))))
#+END_SRC
#+MACRO: guile-version src_emacs-lisp[:exports results :wrap]{guile-version}
#+MACRO: racket-version src_emacs-lisp[:exports results :wrap]{racket-version}
These tests are being run with guile version {{{guile-version}}}, and racket version {{{racket-version}}}.
# Create source block to restore the settings
#+NAME: geiser-restore
#+BEGIN_SRC emacs-lisp :wrap "SRC emacs-lisp :exports both" :exports results
(let ((generate-script
(lambda (v)
(if v (concat
"'"
(with-output-to-string (princ v)))
"nil"))))
(concat "(progn\n "
"(setq org-babel-default-header-args:scheme \n "
(funcall generate-script org-babel-default-header-args:scheme)
")\n"
"(setq geiser-default-implementation \n "
(funcall generate-script geiser-default-implementation)
")\n"
"(setq geiser-active-implementations \n "
(funcall generate-script geiser-active-implementations)
"))"))
#+END_SRC
+ Set values to (), nil, (guile, racket)
#+BEGIN_SRC emacs-lisp :wrap :exports both :results output
(setq org-babel-default-header-args:scheme (list))
(setq geiser-default-implementation nil)
(setq geiser-active-implementations '(guile racket))
#+END_SRC
+ Run; verify guile
This block should return {{{guile-version}}}:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ Reverse geiser-active-implementations
#+BEGIN_SRC emacs-lisp :exports both :results value
(setq geiser-active-implementations
(reverse geiser-active-implementations))
#+END_SRC
+ Run; verify racket
This block should return {{{racket-version}}}:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ Set geiser-default-implementation to guile
#+BEGIN_SRC emacs-lisp :exports both
(setq geiser-default-implementation 'guile)
#+END_SRC
+ Run; verify guile
This block should return {{{guile-version}}}:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ Set =org-babel-default-header-args:scheme= to =(('scheme . 'racket))=:
#+BEGIN_SRC emacs-lisp :exports both
(setq org-babel-default-header-args:scheme
'((:scheme . "racket")))
#+END_SRC
+ Run; verify
This block should return {{{racket-version}}}:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ Run a block with =:scheme guile=; expect guile.
This block should return {{{guile-version}}}:
#+BEGIN_SRC scheme :scheme guile
(version)
#+END_SRC
+ Restore variables
#+RESULTS: geiser-restore
#+BEGIN_SRC emacs-lisp :exports both
(progn
(setq org-babel-default-header-args:scheme nil)
(setq geiser-default-implementation nil)
(setq geiser-active-implementations '))
#+END_SRC
#+BEGIN_SRC emacs-lisp :wrap :exports results
(list (list "Variable" "Value")
(list "org-babel-default-header-args:scheme"
org-babel-default-header-args:scheme)
(list "geiser-default-implementation"
geiser-default-implementation)
(list "geiser-active-implementations"
geiser-active-implementations))
#+END_SRC
* sessions
+ Without a session, re-define 'version':
#+BEGIN_SRC scheme :exports code
(define version (lambda () "This test fails."))
#+END_SRC
+ In a new block, without a session, (version) should return a number:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ With an unamed session, re-define 'version':
#+BEGIN_SRC scheme :session :exports code
(define version
(lambda ()
"This is the unnamed session."))
#+END_SRC
+ In a new block, with an unnamed session, (version) should return =This is
the unnamed session=:
#+BEGIN_SRC scheme :session
(version)
#+END_SRC
Make sure the change doesn't affect a non-session block:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ Start a named session, and re-define 'version':
#+BEGIN_SRC scheme :session named-session-1 :exports code
(define version
(lambda ()
"This is named-session-1."))
#+END_SRC
+ Make sure the change doesn't affect a non-session block:
#+BEGIN_SRC scheme
(version)
#+END_SRC
+ ...or an unnamed session block:
#+BEGIN_SRC scheme :session
(version)
#+END_SRC
+ ...but is retained for a new block with the same session name:
#+BEGIN_SRC scheme :session named-session-1
(version)
#+END_SRC
* output vs. value
:PROPERTIES:
:session: output-value-session
:END:
#+BEGIN_SRC scheme :results output
(display "This test pases")
"This test FAILS"
#+END_SRC
#+BEGIN_SRC scheme :results value
(display "This test FAILS")
"This test passes"
#+END_SRC
#+BEGIN_SRC scheme :results output
(display "This is the first line.")
(newline)
(display "This is the second line.\n")
(display "This is the third line.")
"This test FAILS."
#+END_SRC
#+BEGIN_SRC scheme :results value
(display "This test FAILS.")
(string-join
(list "This is the first line."
"This is the second line."
"This is the third line.")
"\n")
#+END_SRC
#+BEGIN_SRC scheme :results output
(display '(1 2 3 4 5 6))
"This test FAILS"
#+END_SRC
#+BEGIN_SRC scheme :results value :wrap
(display "This test FAILS")
'(1 2 3 4 5 6)
#+END_SRC
#+BEGIN_SRC scheme :results output
(display '((1 2 3)(4 5 6)(7 8 9)))
"This test FAILS"
#+END_SRC
#+BEGIN_SRC scheme :results value
(display "This test FAILS")
'((1 2 3)(4 5 6)(7 8 9))
#+END_SRC
* :var
This block should return =64=:
#+BEGIN_SRC scheme :results value :var x=8
(* x x)
#+END_SRC
This block should return the string ="A B C D E"=:
#+BEGIN_SRC scheme :results value :var y="E D C B A"
(string-reverse y)
#+END_SRC
This block should return the list =(1 4 9 16 25)= (which org will display as a table).
#+BEGIN_SRC scheme :results value :var z='(1 2 3 4 5) :wrap nil
(map (lambda (x) (* x x)) z)
#+END_SRC
* Tables
:PROPERTIES:
:wrap: nil
:session: nil
:END:
Pass a table to scheme:
#+NAME: data-table
| | A | B | C | D | E |
| Row 1 | 1 | 2 | 3 | 4 | 5 |
| Row 2 | 6 | 7 | 8 | 9 | 10 |
This block should show the table above:
#+BEGIN_SRC scheme :scheme racket :results value :session :var x=data-table
x
#+END_SRC
This block rerses the table left to right:
#+BEGIN_SRC scheme :scheme racket :results value :session :var x=data-table
(map reverse x)
#+END_SRC
This block will be passed to scheme with the column headers removed; the data
and row labels will be reversed, but the column labels will not.
#+BEGIN_SRC scheme :scheme guile :results value :session :var x=data-table :colnames t
(map reverse x)
#+END_SRC
This block will be passed to scheme with the row headers removed; the data
and column labels will be reversed, but the row labels will not.
#+BEGIN_SRC scheme :scheme guile :results value :session :var x=data-table :rownames t
(map reverse x)
#+END_SRC
This block will be passed to scheme with bothe the row and column headers
removed; the data will be reversed, but the row and columns labels will not.
#+BEGIN_SRC scheme :scheme guile :results value :session :var x=data-table :colnames nil :rownames t
(map reverse x)
#+END_SRC
This block will adds a row of data; note that the column and row headers are lost:
#+BEGIN_SRC scheme :scheme guile :results value :session :var t=data-table :colnames t :rownames t
(let* ((row-1 (car t))
(row-2 (cadr t))
(total (map + row-1 row-2)))
(append t (list total)))
#+END_SRC
This block adds a row of data, but handles the column and row headers in scheme:
#+BEGIN_SRC scheme :scheme guile :results value :session :var t=data-table
(let* ((col-labels (car t))
(row-1 (cadr t))
(row-2 (caddr t))
(total (append
'(Total)
(map + (cdr row-1) (cdr row-2)))))
(append t (list total)))
#+END_SRC
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 899 bytes --]
^ permalink raw reply related [flat|nested] 6+ messages in thread
* Re: [PATCH] Babel support for scheme using geiser
2013-01-04 19:18 [PATCH] Babel support for scheme using geiser Michael Gauland
@ 2013-01-05 14:42 ` Bastien
2013-01-05 18:57 ` Michael Gauland
0 siblings, 1 reply; 6+ messages in thread
From: Bastien @ 2013-01-05 14:42 UTC (permalink / raw)
To: Michael Gauland; +Cc: emacs-orgmode Org-Mode
Hi Michael,
Michael Gauland <mikelygee@no8wireless.co.nz> writes:
> Babel: User geiser for scheme interactions
>
> * lisp/ob-scheme.el Major rewrite to support geiser
thanks for the patch -- let's wait for FSF copyright assignment
process to be done. In the meantime, please consider adding a
commit ChangeLog for your patch, avoid dangling parentheses,
and don't overwrite the first line... we are in 2013 :-)
If you havn't already, please read this page:
http://orgmode.org/worg/org-contribute.html#sec-5
Thanks for contributing!
--
Bastien
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [PATCH] Babel support for scheme using geiser
2013-01-05 14:42 ` Bastien
@ 2013-01-05 18:57 ` Michael Gauland
2013-01-06 6:56 ` Bastien
0 siblings, 1 reply; 6+ messages in thread
From: Michael Gauland @ 2013-01-05 18:57 UTC (permalink / raw)
To: emacs-orgmode
Bastien <bzg <at> altern.org> writes:
> In the meantime, please consider adding a
> commit ChangeLog for your patch,
Most of the file has changed dramatically--would you like the changelog to list
all the functions that have been added or altered, or would a simple statement
that the file underwent a major re-write be more appropriate?
> ...avoid dangling parentheses,
Noted. That's a bad habit I've picked up somewhere (probably too many years of C
programming.)
> and don't overwrite the first line... we are in 2013
Also noted. Part of my brain refuses to acknowledge the new year until I'm back
at work. Regrettably, that won't be a problem after tomorrow.
Kind Regards,
Mike
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [PATCH] Babel support for scheme using geiser
2013-01-05 18:57 ` Michael Gauland
@ 2013-01-06 6:56 ` Bastien
2013-01-08 23:46 ` [PATCH] Use geiser for babel scheme evaluation Michael Gauland
0 siblings, 1 reply; 6+ messages in thread
From: Bastien @ 2013-01-06 6:56 UTC (permalink / raw)
To: Michael Gauland; +Cc: emacs-orgmode
Hi Michael,
Michael Gauland <mikelygee@no8wireless.co.nz> writes:
> Bastien <bzg <at> altern.org> writes:
>> In the meantime, please consider adding a
>> commit ChangeLog for your patch,
>
> Most of the file has changed dramatically--would you like the changelog to list
> all the functions that have been added or altered, or would a simple statement
> that the file underwent a major re-write be more appropriate?
Well, I'm afraid we'll have to go the clean way: just document
the deleted functions, the new ones, and the ones that have been
rewritten. No need to go too much into details.
Also let's rename `cleanse-org-babel-scheme-repl-map' to
`org-babel-scheme-cleanse-repl-map'.
>> ...avoid dangling parentheses,
>
> Noted. That's a bad habit I've picked up somewhere (probably too many years of C
> programming.)
>
>> and don't overwrite the first line... we are in 2013
>
> Also noted. Part of my brain refuses to acknowledge the new year until I'm back
> at work. Regrettably, that won't be a problem after tomorrow.
Hehe, happy new year :)
--
Bastien
^ permalink raw reply [flat|nested] 6+ messages in thread
* [PATCH] Use geiser for babel scheme evaluation.
2013-01-06 6:56 ` Bastien
@ 2013-01-08 23:46 ` Michael Gauland
2013-01-09 8:23 ` Bastien
0 siblings, 1 reply; 6+ messages in thread
From: Michael Gauland @ 2013-01-08 23:46 UTC (permalink / raw)
To: Bastien; +Cc: emacs-orgmode
[-- Attachment #1.1: Type: text/plain, Size: 1576 bytes --]
On 06/01/13 19:56, Bastien wrote:
> Well, I'm afraid we'll have to go the clean way: just document the
> deleted functions, the new ones, and the ones that have been
> rewritten. No need to go too much into details. Also let's rename
> `cleanse-org-babel-scheme-repl-map' to
> `org-babel-scheme-cleanse-repl-map'.
I've done the rename, un-dangled the parentheses, and prepared a changelog:
Babel: Use geiser to manage scheme sessions
* lisp/ob-scheme.el: Load the geiser library
(run-scheme): Removed
(org-babel-scheme-eoe): Removed
(org-babel-scheme-cmd): Removed
(scheme-program-name): Removed
(org-babel-scheme-repl-map): Hash mapping session names to sessions.
(org-babel-scheme-cleanse-repl-map): Remove dead sessions from map.
(org-babel-scheme-get-session-buffer): Return buffer associated with a
session.
(org-babel-scheme-set-session-buffer): Record the buffer associated with
a session.
(org-babel-scheme-get-buffer-impl): Return the scheme implementation
geiser associates with a buffer.
(org-babel-scheme-get-repl): Switch to the scheme REPL buffer for a
session, creating it if it doesn't exist.
(org-bable-scheme-make-session-name): Generate a name for a session, if
one was not specified.
(org-babel-scheme-execute-with-geiser): Execute scheme code, creating
the REPL if necessary.
(org-babel-execute-scheme): Rewritten to use geiser.
(org-babel-prep-session:scheme): Removed
(org-babel-scheme-initiate-session): Removed
This uses geiser to evaluate babel scheme source blocks, and generally
improves scheme support.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-Use-geiser-for-babel-scheme-evaluation.patch --]
[-- Type: text/x-diff; name="0001-Use-geiser-for-babel-scheme-evaluation.patch", Size: 9195 bytes --]
From bc33a46041086abd5d1fec321f104aa034823576 Mon Sep 17 00:00:00 2001
From: Michael Gauland <mike_gauland@stanfordalumni.org>
Date: Wed, 9 Jan 2013 12:41:13 +1300
Subject: [PATCH] Use geiser for babel scheme evaluation.
---
lisp/ob-scheme.el | 192 ++++++++++++++++++++++++++++++++---------------------
1 files changed, 117 insertions(+), 75 deletions(-)
diff --git a/lisp/ob-scheme.el b/lisp/ob-scheme.el
index c9fa44a..31e0cad 100644
--- a/lisp/ob-scheme.el
+++ b/lisp/ob-scheme.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
-;; Author: Eric Schulte
+;; Authors: Eric Schulte, Michael Gauland
;; Keywords: literate programming, reproducible research, scheme
;; Homepage: http://orgmode.org
@@ -33,27 +33,16 @@
;; - a working scheme implementation
;; (e.g. guile http://www.gnu.org/software/guile/guile.html)
;;
-;; - for session based evaluation cmuscheme.el is required which is
-;; included in Emacs
+;; - for session based evaluation geiser is required, which is available from
+;; ELPA.
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
-
-(declare-function run-scheme "ext:cmuscheme" (cmd))
+(load-library "geiser-impl")
(defvar org-babel-default-header-args:scheme '()
"Default header arguments for scheme code blocks.")
-(defvar org-babel-scheme-eoe "org-babel-scheme-eoe"
- "String to indicate that evaluation has completed.")
-
-(defcustom org-babel-scheme-cmd "guile"
- "Name of command used to evaluate scheme blocks."
- :group 'org-babel
- :version "24.1"
- :type 'string)
-
(defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
@@ -65,70 +54,123 @@
")\n" body ")")
body)))
-(defvar scheme-program-name)
+
+(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)
+ (when (not (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."
+ (let ((result
+ (cond ((not name)
+ (concat buffer " " (symbol-name impl) " REPL"))
+ ((string= name "none") nil)
+ (name))))
+ result))
+
+(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 (if output
+ (format "(with-output-to-string (lambda () %s))" code)
+ code))
+ (geiser-mode)
+ (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)
+ (geiser-eval-region (point-min) (point-max))
+ (setq result
+ (if (equal (substring (current-message) 0 3) "=> ")
+ (replace-regexp-in-string "^=> " "" (current-message))
+ "\"An error occurred.\""))
+ (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))
+ (setq result (if (or (string= result "#<void>")
+ (string= result "#<unspecified>"))
+ nil
+ (read result)))))
+ result))
+
(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* ((result-type (cdr (assoc :result-type params)))
- (org-babel-scheme-cmd (or (cdr (assoc :scheme params))
- org-babel-scheme-cmd))
- (full-body (org-babel-expand-body:scheme body params)))
- (read
- (if (not (string= (cdr (assoc :session params)) "none"))
- ;; session evaluation
- (let ((session (org-babel-prep-session:scheme
- (cdr (assoc :session params)) params)))
- (org-babel-comint-with-output
- (session (format "%S" org-babel-scheme-eoe) t body)
- (mapc
- (lambda (line)
- (insert (org-babel-chomp line)) (comint-send-input nil t))
- (list body (format "%S" org-babel-scheme-eoe)))))
- ;; external evaluation
- (let ((script-file (org-babel-temp-file "scheme-script-")))
- (with-temp-file script-file
- (insert
- ;; return the value or the output
- (if (string= result-type "value")
- (format "(display %s)" full-body)
- full-body)))
- (org-babel-eval
- (format "%s %s" org-babel-scheme-cmd
- (org-babel-process-file-name script-file)) ""))))))
-
-(defun org-babel-prep-session:scheme (session params)
- "Prepare SESSION according to the header arguments specified in PARAMS."
- (let* ((session (org-babel-scheme-initiate-session session))
- (vars (mapcar #'cdr (org-babel-get-header params :var)))
- (var-lines
- (mapcar
- (lambda (var) (format "%S" (print `(define ,(car var) ',(cdr var)))))
- vars)))
- (when session
- (org-babel-comint-in-buffer session
- (sit-for .5) (goto-char (point-max))
- (mapc (lambda (var)
- (insert var) (comint-send-input nil t)
- (org-babel-comint-wait-for-output session)
- (sit-for .1) (goto-char (point-max))) var-lines)))
- session))
-
-(defun org-babel-scheme-initiate-session (&optional session)
- "If there is not a current inferior-process-buffer in SESSION
-then create. Return the initialized session."
- (require 'cmuscheme)
- (unless (string= session "none")
- (let ((session-buffer (save-window-excursion
- (run-scheme org-babel-scheme-cmd)
- (rename-buffer session)
- (current-buffer))))
- (if (org-babel-comint-buffer-livep session-buffer)
- (progn (sit-for .25) session-buffer)
- (sit-for .5)
- (org-babel-scheme-initiate-session session)))))
+ (let* ((source-buffer (current-buffer))
+ (source-buffer-name (replace-regexp-in-string ;; zap surrounding *
+ "^ ?\\*\\([^*]+\\)\\*" "\\1" (buffer-name source-buffer))))
+ (save-excursion
+ (org-babel-reassemble-table
+ (let* ((result-type (cdr (assoc :result-type params)))
+ (impl (or (when (cdr (assoc :scheme params))
+ (intern (cdr (assoc :scheme params))))
+ geiser-default-implementation
+ (car geiser-active-implementations)))
+ (session (org-babel-scheme-make-session-name source-buffer-name (cdr (assoc :session params)) impl))
+ (full-body (org-babel-expand-body:scheme body params)))
+ (org-babel-scheme-execute-with-geiser full-body ; code
+ (string= result-type "output") ; output?
+ impl ; implementation
+ (and (not (string= session "none")) session)); session
+ )
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colnames params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rownames params)))))))
+
(provide 'ob-scheme)
-
-
;;; ob-scheme.el ends here
--
1.7.2.5
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 899 bytes --]
^ permalink raw reply related [flat|nested] 6+ messages in thread
* Re: [PATCH] Use geiser for babel scheme evaluation.
2013-01-08 23:46 ` [PATCH] Use geiser for babel scheme evaluation Michael Gauland
@ 2013-01-09 8:23 ` Bastien
0 siblings, 0 replies; 6+ messages in thread
From: Bastien @ 2013-01-09 8:23 UTC (permalink / raw)
To: Michael Gauland; +Cc: emacs-orgmode
Hi Michael,
Michael Gauland <mikelygee@no8wireless.co.nz> writes:
> I've done the rename, un-dangled the parentheses, and prepared a
> changelog:
Thanks Michael. I ping'ed the FSF copyright clerk for some news,
I hope he's not overwhelmed after Christmas holidays.
Best,
PS: Next time put the ChangeLog directly in the commit message,
that's even quicker for me.
--
Bastien
^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2013-01-09 8:23 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-01-04 19:18 [PATCH] Babel support for scheme using geiser Michael Gauland
2013-01-05 14:42 ` Bastien
2013-01-05 18:57 ` Michael Gauland
2013-01-06 6:56 ` Bastien
2013-01-08 23:46 ` [PATCH] Use geiser for babel scheme evaluation Michael Gauland
2013-01-09 8:23 ` Bastien
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).