daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

update packages

Browse Source
This commit is contained in:
Daniel Weschke
2025-06-22 17:08:08 +02:00
parent 54e5633369
commit 16a0a6db93
558 changed files with 68349 additions and 26568 deletions
Download Patch File Download Diff File Expand all files Collapse all files

125
lisp/org/ob-scheme.el
View File

@@ -1,6 +1,6 @@
;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2023 Free Software Foundation, Inc.
;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
;; Authors: Eric Schulte
;; Michael Gauland
@@ -54,7 +54,7 @@
(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 geiser-connect "ext:geiser-repl" (impl &optional host port))
(declare-function run-geiser "ext:geiser-repl" (impl))
(declare-function geiser "ext:geiser-repl" (impl))
(declare-function geiser-mode "ext:geiser-mode" ())
@@ -65,6 +65,9 @@
(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))
(declare-function geiser-eval--retort-error "ext:geiser-eval" (ret))
(declare-function geiser-eval--retort-error-msg "ext:geiser-eval" (err))
(declare-function geiser-eval--error-msg "ext:geiser-eval" (err))
(defcustom org-babel-scheme-null-to 'hline
"Replace `null' and empty lists in scheme tables with this before returning."
@@ -75,6 +78,17 @@
(defvar org-babel-default-header-args:scheme '()
"Default header arguments for scheme code blocks.")
(defconst org-babel-header-args:scheme '((host . :any)
(port . :any))
"Header arguments supported in Scheme.")
(defun org-babel-scheme-expand-header-arg-vars (vars)
"Expand :var header arguments given as VARS."
(mapconcat
(lambda (var)
(format "(define %S %S)" (car var) (cdr var)))
vars
"\n"))
(defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body."
@@ -83,13 +97,7 @@
(postpends (cdr (assq :epilogue 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))
(concat (org-babel-scheme-expand-header-arg-vars vars) "\n" body))
(and postpends (concat "\n" postpends)))))
@@ -116,13 +124,17 @@
(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."
(defun org-babel-scheme-get-repl (impl name &optional host port)
"Switch to a Scheme REPL, creating it if it doesn't exist.
If the variables HOST and PORT are set, connect to the running Scheme REPL."
(let ((buffer (org-babel-scheme-get-session-buffer name)))
(or buffer
(progn
(if (fboundp 'geiser)
(geiser impl)
(if (and host port)
(geiser-connect impl host port)
(geiser impl))
;; Obsolete since Geiser 0.26.
(run-geiser impl))
(when name
@@ -131,14 +143,14 @@
(current-buffer)))))
(defun org-babel-scheme-make-session-name (buffer name impl)
"Generate a name for the session buffer.
"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."
`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)))
@@ -159,7 +171,7 @@ org-babel-scheme-execute-with-geiser will use a temporary session."
,@body
(current-message))))
(defun org-babel-scheme-execute-with-geiser (code output impl repl)
(defun org-babel-scheme-execute-with-geiser (code output impl repl &optional host port)
"Execute code in specified REPL.
If the REPL doesn't exist, create it using the given scheme
implementation.
@@ -170,45 +182,58 @@ is true; otherwise returns the last value."
(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
(let ((beg (point)))
(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 host port))))
(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))
;; `geiser-eval-region/wait' was introduced to await the
;; result of async evaluation in geiser version 0.22.
(let ((ret (funcall (if (fboundp 'geiser-eval-region/wait)
#'geiser-eval-region/wait
#'geiser-eval-region)
(point-min)
(point-max))))
(setq result (if output
(or (geiser-eval--retort-output ret)
"Geiser Interpreter produced no output")
(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)))))
(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))
;; `geiser-eval-region/wait' was introduced to await the
;; result of async evaluation in geiser version 0.22.
(let ((ret (funcall (if (fboundp 'geiser-eval-region/wait)
#'geiser-eval-region/wait
#'geiser-eval-region)
;; Do not include top comment into evaluation.
;; Apparently, mit-scheme has
;; problems with the top comment we add:
;; "Unexpected read restart on: #[textual-i/o-port 27 for console]"
beg
(point-max))))
(let ((err (geiser-eval--retort-error ret)))
(setq result (cond
(output
(or (geiser-eval--retort-output ret)
"Geiser Interpreter produced no output"))
(err nil)
(t (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))
(when err
(let ((msg (geiser-eval--error-msg err)))
(org-babel-eval-error-notify
nil
(concat (if (listp msg) (car msg) msg) "\n")))))))))))
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)))
(let ((res (and results (org-babel-script-escape results))))
(cond ((listp res)
(mapcar (lambda (el)
(if (or (null el) (eq el 'null))
@@ -231,6 +256,8 @@ This function is called by `org-babel-execute-src-block'."
geiser-scheme-implementation
geiser-default-implementation
(car geiser-active-implementations)))
(host (cdr (assq :host params)))
(port (cdr (assq :port params)))
(session (org-babel-scheme-make-session-name
source-buffer-name (cdr (assq :session params)) impl))
(full-body (org-babel-expand-body:scheme body params))
@@ -240,7 +267,9 @@ This function is called by `org-babel-execute-src-block'."
full-body ; code
(string= result-type "output") ; output?
impl ; implementation
(and (not (string= session "none")) session)))) ; session
(and (not (string= session "none")) session) ; session
host ; REPL host
port))) ; REPL port
(let ((table
(org-babel-reassemble-table
result