Merge branch 'master' of orgmode.org:org-mode

This commit is contained in:
Bastien Guerry 2013-07-01 12:16:50 +02:00
commit 683e1db203
5 changed files with 143 additions and 89 deletions

View File

@ -1169,9 +1169,12 @@ the current subtree."
(defun org-babel-set-current-result-hash (hash) (defun org-babel-set-current-result-hash (hash)
"Set the current in-buffer hash to HASH." "Set the current in-buffer hash to HASH."
(org-babel-where-is-src-block-result) (org-babel-where-is-src-block-result)
(save-excursion (goto-char (match-beginning 3)) (save-excursion (goto-char (match-beginning 5))
;; (mapc #'delete-overlay (overlays-at (point))) (mapc #'delete-overlay (overlays-at (point)))
(replace-match hash nil nil nil 3) (forward-char org-babel-hash-show)
(mapc #'delete-overlay (overlays-at (point)))
(replace-match hash nil nil nil 5)
(goto-char (point-at-bol))
(org-babel-hide-hash))) (org-babel-hide-hash)))
(defun org-babel-hide-hash () (defun org-babel-hide-hash ()
@ -1717,7 +1720,8 @@ buffer or nil if no such result exists."
(when (and (string= "name" (downcase (match-string 1))) (when (and (string= "name" (downcase (match-string 1)))
(or (beginning-of-line 1) (or (beginning-of-line 1)
(looking-at org-babel-src-block-regexp) (looking-at org-babel-src-block-regexp)
(looking-at org-babel-multi-line-header-regexp))) (looking-at org-babel-multi-line-header-regexp)
(looking-at org-babel-lob-one-liner-regexp)))
(throw 'is-a-code-block (org-babel-find-named-result name (point)))) (throw 'is-a-code-block (org-babel-find-named-result name (point))))
(beginning-of-line 0) (point)))))) (beginning-of-line 0) (point))))))
@ -1822,10 +1826,7 @@ following the source block."
(looking-at org-babel-lob-one-liner-regexp))) (looking-at org-babel-lob-one-liner-regexp)))
(inlinep (when (org-babel-get-inline-src-block-matches) (inlinep (when (org-babel-get-inline-src-block-matches)
(match-end 0))) (match-end 0)))
(name (if on-lob-line (name (nth 4 (or info (org-babel-get-src-block-info 'light))))
(mapconcat #'identity (butlast (org-babel-lob-get-info))
"")
(nth 4 (or info (org-babel-get-src-block-info 'light)))))
(head (unless on-lob-line (org-babel-where-is-src-block-head))) (head (unless on-lob-line (org-babel-where-is-src-block-head)))
found beg end) found beg end)
(when head (goto-char head)) (when head (goto-char head))

View File

@ -217,7 +217,7 @@ this template."
(concat (concat
":var results=" ":var results="
(mapconcat 'identity (mapconcat 'identity
(butlast lob-info) (butlast lob-info 2)
" "))))))) " ")))))))
"" nil (car (last lob-info))) "" nil (car (last lob-info)))
'lob)) 'lob))

View File

@ -114,12 +114,20 @@ if so then run the appropriate source block from the Library."
(or (funcall nonempty 8 19) "")) (or (funcall nonempty 8 19) ""))
(funcall nonempty 9 18))) (funcall nonempty 9 18)))
(list (length (if (= (length (match-string 12)) 0) (list (length (if (= (length (match-string 12)) 0)
(match-string 2) (match-string 11))))))))) (match-string 2) (match-string 11)))
(save-excursion
(forward-line -1)
(and (looking-at (concat org-babel-src-name-regexp
"\\([^\n]*\\)$"))
(org-no-properties (match-string 1))))))))))
(defvar org-babel-default-header-args:emacs-lisp) ; Defined in ob-emacs-lisp.el (defvar org-babel-default-header-args:emacs-lisp) ; Defined in ob-emacs-lisp.el
(defun org-babel-lob-execute (info) (defun org-babel-lob-execute (info)
"Execute the lob call specified by INFO." "Execute the lob call specified by INFO."
(let* ((mkinfo (lambda (p) (list "emacs-lisp" "results" p nil nil (nth 2 info)))) (let* ((mkinfo (lambda (p)
(list "emacs-lisp" "results" p nil
(nth 3 info) ;; name
(nth 2 info))))
(pre-params (apply #'org-babel-merge-params (pre-params (apply #'org-babel-merge-params
org-babel-default-header-args org-babel-default-header-args
org-babel-default-header-args:emacs-lisp org-babel-default-header-args:emacs-lisp
@ -130,7 +138,7 @@ if so then run the appropriate source block from the Library."
(org-no-properties (org-no-properties
(concat (concat
":var results=" ":var results="
(mapconcat #'identity (butlast info) (mapconcat #'identity (butlast info 2)
" ")))))))) " "))))))))
(pre-info (funcall mkinfo pre-params)) (pre-info (funcall mkinfo pre-params))
(cache-p (and (cdr (assoc :cache pre-params)) (cache-p (and (cdr (assoc :cache pre-params))

View File

@ -2,7 +2,7 @@
;; Copyright (C) 2010-2013 Free Software Foundation, Inc. ;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
;; Author: Eric Schulte ;; Authors: Eric Schulte, Michael Gauland
;; Keywords: literate programming, reproducible research, scheme ;; Keywords: literate programming, reproducible research, scheme
;; Homepage: http://orgmode.org ;; Homepage: http://orgmode.org
@ -33,27 +33,16 @@
;; - a working scheme implementation ;; - a working scheme implementation
;; (e.g. guile http://www.gnu.org/software/guile/guile.html) ;; (e.g. guile http://www.gnu.org/software/guile/guile.html)
;; ;;
;; - for session based evaluation cmuscheme.el is required which is ;; - for session based evaluation geiser is required, which is available from
;; included in Emacs ;; ELPA.
;;; Code: ;;; Code:
(require 'ob) (require 'ob)
(eval-when-compile (require 'cl)) (load-library "geiser-impl")
(declare-function run-scheme "ext:cmuscheme" (cmd))
(defvar org-babel-default-header-args:scheme '() (defvar org-babel-default-header-args:scheme '()
"Default header arguments for scheme code blocks.") "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) (defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body." "Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
@ -65,72 +54,127 @@
")\n" body ")") ")\n" body ")")
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) (defun org-babel-execute:scheme (body params)
"Execute a block of Scheme code with org-babel. "Execute a block of Scheme code with org-babel.
This function is called by `org-babel-execute-src-block'" This function is called by `org-babel-execute-src-block'"
(let* ((result-type (cdr (assoc :result-type params))) (let* ((source-buffer (current-buffer))
(org-babel-scheme-cmd (or (cdr (assoc :scheme params)) (source-buffer-name (replace-regexp-in-string ;; zap surrounding *
org-babel-scheme-cmd)) "^ ?\\*\\([^*]+\\)\\*" "\\1"
(full-body (org-babel-expand-body:scheme body params)) (buffer-name source-buffer))))
(result (if (not (string= (cdr (assoc :session params)) "none")) (save-excursion
;; session evaluation (org-babel-reassemble-table
(let ((session (org-babel-prep-session:scheme (let* ((result-type (cdr (assoc :result-type params)))
(cdr (assoc :session params)) params))) (impl (or (when (cdr (assoc :scheme params))
(org-babel-comint-with-output (intern (cdr (assoc :scheme params))))
(session (format "%S" org-babel-scheme-eoe) t body) geiser-default-implementation
(mapc (car geiser-active-implementations)))
(lambda (line) (session (org-babel-scheme-make-session-name
(insert (org-babel-chomp line)) source-buffer-name (cdr (assoc :session params)) impl))
(comint-send-input nil t)) (full-body (org-babel-expand-body:scheme body params)))
(list body (format "%S" org-babel-scheme-eoe))))) (org-babel-scheme-execute-with-geiser
;; external evaluation full-body ; code
(let ((script-file (org-babel-temp-file "scheme-script-"))) (string= result-type "output") ; output?
(with-temp-file script-file impl ; implementation
(insert (and (not (string= session "none")) session))) ; session
;; return the value or the output (org-babel-pick-name (cdr (assoc :colname-names params))
(if (string= result-type "value") (cdr (assoc :colnames params)))
(format "(display %s)" full-body) (org-babel-pick-name (cdr (assoc :rowname-names params))
full-body))) (cdr (assoc :rownames params)))))))
(org-babel-eval
(format "%s %s" org-babel-scheme-cmd
(org-babel-process-file-name script-file)) "")))))
(org-babel-result-cond (cdr (assoc :result-params params))
result (read result))))
(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)))))
(provide 'ob-scheme) (provide 'ob-scheme)
;;; ob-scheme.el ends here ;;; ob-scheme.el ends here

View File

@ -217,6 +217,7 @@ Here is one at the end of a line. =2=
(should-not (string-match (regexp-quote "i=\"10\"") result))))) (should-not (string-match (regexp-quote "i=\"10\"") result)))))
(ert-deftest ob-exp/use-case-of-reading-entry-properties () (ert-deftest ob-exp/use-case-of-reading-entry-properties ()
:expected-result :failed ;; TODO: update for new call line result insertion
(org-test-at-id "cc5fbc20-bca5-437a-a7b8-2b4d7a03f820" (org-test-at-id "cc5fbc20-bca5-437a-a7b8-2b4d7a03f820"
(org-narrow-to-subtree) (org-narrow-to-subtree)
(let* ((case-fold-search nil) (let* ((case-fold-search nil)