diff options
Diffstat (limited to 'elisp/geiser-connection.el')
| -rw-r--r-- | elisp/geiser-connection.el | 91 |
1 files changed, 49 insertions, 42 deletions
diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el index c45a37a..5305cd8 100644 --- a/elisp/geiser-connection.el +++ b/elisp/geiser-connection.el @@ -17,6 +17,7 @@ (require 'geiser-log) (require 'geiser-syntax) (require 'geiser-base) +(require 'geiser-impl) (require 'comint) (require 'advice) @@ -77,13 +78,20 @@ (cons :count 0) (cons :completed (make-hash-table :weakness 'value)) (cons :buffer buffer) - (cons :timer nil) - (cons :reply (geiser-con--make-reply-buffer (buffer-name buffer))))) + (cons :reply (geiser-con--make-reply-buffer buffer)))) -(defun geiser-con--make-reply-buffer (n) - (let ((rb (generate-new-buffer (concat " geiser-con-reply: " n)))) - (buffer-disable-undo rb) - rb)) +(defvar geiser-con--eot-regexp nil) +(geiser-impl--register-local-variable + 'geiser-con--eot-regexp 'eot-regexp nil + "A regular expression used to detect end of transmissions. +By default, Geiser uses the prompt regexp.") + +(defun geiser-con--make-reply-buffer (buffer) + (let ((name (concat " geiser-con-reply: " (buffer-name buffer))) + (eot (with-current-buffer buffer geiser-con--eot-regexp))) + (with-current-buffer (get-buffer-create name) + (setq geiser-con--eot-regexp eot) + (current-buffer)))) (defsubst geiser-con--connection-p (c) (and (listp c) (eq (car c) :geiser-connection))) @@ -103,11 +111,15 @@ (defsubst geiser-con--connection-reply-buffer (c) (cdr (assoc :reply c))) +(defsubst geiser-con--connection-completed (c r) + (geiser-con--request-deactivate req) + (puthash (geiser-con--request-id r) r (cdr (assoc :completed c)))) + (defun geiser-con--connection-clean-current-request (c) (let* ((cell (assoc :current c)) (req (cdr cell))) (when req - (puthash (geiser-con--request-id req) req (cdr (assoc :completed c))) + (geiser-con--connection-completed c req) (setcdr cell nil)))) (defun geiser-con--connection-add-request (c r) @@ -118,13 +130,17 @@ (gethash id (cdr (assoc :completed c)))) (defun geiser-con--connection-pop-request (c) - (let ((reqs (assoc :requests c)) - (current (assoc :current c))) - (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs)))) - (if (and (cdr current) - (geiser-con--request-deactivated-p (cdr current))) + (let* ((reqs (assoc :requests c)) + (current (assoc :current c)) + (old-current (cdr current)) + (new-current (cadr reqs)) + (new-reqs (cddr reqs))) + (when old-current (geiser-con--connection-completed c old-current)) + (setcdr reqs new-reqs) + (if (and new-current + (geiser-con--request-deactivated-p new-current)) (geiser-con--connection-pop-request c) - (cdr current)))) + (setcdr current new-current)))) (defun geiser-con--connection-inc-count (c) (let* ((cnt (assoc :count c)) @@ -176,13 +192,11 @@ (setq geiser-con--debugging-prompt-regexp debug-prompt-regexp) (setq geiser-con--debugging-preamble-regexp debug-preamble-regexp) (setq geiser-con--connection (geiser-con--make-connection buffer)) - (set (make-local-variable 'comint-redirect-insert-matching-regexp) - (not (null debug-prompt-regexp))) - (set (make-local-variable 'comint-redirect-finished-regexp) - (if debug-prompt-regexp - (format "\\(%s\\)\\|\\(%s\\)" prompt-regexp debug-prompt-regexp) - prompt-regexp)) - (setq comint-prompt-regexp comint-redirect-finished-regexp) + (set (make-local-variable 'comint-redirect-insert-matching-regexp) t) + (setq comint-prompt-regexp + (if debug-prompt-regexp + (format "\\(%s\\)\\|\\(%s\\)" prompt-regexp debug-prompt-regexp) + prompt-regexp)) (add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t))) @@ -207,10 +221,6 @@ (defun geiser-con--process-next (con) (when (not (geiser-con--connection-current-request con)) (let* ((buffer (geiser-con--connection-buffer con)) - (debug-prompt (with-current-buffer buffer - geiser-con--debugging-prompt-regexp)) - (debug-preamble (with-current-buffer buffer - geiser-con--debugging-preamble-regexp)) (req (geiser-con--connection-pop-request con)) (str (and req (geiser-con--request-string req))) (rbuffer (geiser-con--connection-reply-buffer con))) @@ -219,7 +229,7 @@ (delete-region (point-min) (point-max))) (set-buffer buffer) (if (geiser-con--is-debugging) - (geiser-con--request-deactivate req) + (geiser-con--connection-completed con req) (geiser-log--info "<%s>: %s" (geiser-con--request-id req) str) (comint-redirect-send-command (format "%s" str) rbuffer nil t)))))) @@ -236,24 +246,27 @@ (condition-case cerr (with-current-buffer (or buffer (current-buffer)) (funcall cont form) + (geiser-con--request-deactivate req) (geiser-log--info "<%s>: processed" id)) (error (geiser-log--error - "<%s>: continuation failed %S \n\t%s" id rstr cerr)))))) + "<%s>: continuation failed %S \n\t%s" id rstr cerr)))) + (geiser-con--connection-clean-current-request con))) (defun geiser-con--comint-redirect-hook () (if (not geiser-con--connection) (geiser-log--error "No connection in buffer") (let ((req (geiser-con--connection-current-request geiser-con--connection))) - (if (not req) (geiser-log--error "No current request") - (geiser-con--process-completed-request req) - (geiser-con--connection-clean-current-request - geiser-con--connection))))) + (if (not req) + (geiser-log--error "No current request") + (geiser-con--process-completed-request req))))) (defadvice comint-redirect-setup (after geiser-con--advice (output-buffer comint-buffer finished-regexp &optional echo)) (with-current-buffer comint-buffer + (when geiser-con--eot-regexp + (setq comint-redirect-finished-regexp geiser-con--eot-regexp)) (when geiser-con--connection (setq mode-line-process nil)))) (ad-activate 'comint-redirect-setup) @@ -262,20 +275,11 @@ (defconst geiser-con--error-message "Geiser connection not active") -(defun geiser-con--send-string (buffer/proc str cont &optional sender-buffer) - (save-current-buffer - (let ((con (geiser-con--get-connection buffer/proc))) - (unless con (error geiser-con--error-message)) - (let ((req (geiser-con--make-request con str cont sender-buffer))) - (geiser-con--connection-add-request con req) - (geiser-con--process-next con) - req)))) - (defvar geiser-connection-timeout 30000 "Time limit, in msecs, blocking on synchronous evaluation requests") (defun geiser-con--send-string/wait (buffer/proc str cont - &optional timeout sbuf) + &optional timeout sbuf) (save-current-buffer (let* ((con (geiser-con--get-connection buffer/proc)) (proc (and con (geiser-con--connection-process con)))) @@ -284,17 +288,20 @@ (with-current-buffer (geiser-con--connection-buffer con) (when (geiser-con--is-debugging) (error "Geiser REPL is in debug mode"))) - (let* ((req (geiser-con--send-string buffer/proc str cont sbuf)) + (let* ((req (geiser-con--make-request con str cont sbuf)) (id (and req (geiser-con--request-id req))) (time (or timeout geiser-connection-timeout)) (step 100) (waitsecs (/ step 1000.0))) (when id + (geiser-con--connection-add-request con req) + (geiser-con--process-next con) (condition-case nil (while (and (> time 0) (geiser-con--connection-process con) (not (geiser-con--connection-completed-p con id))) - (unless (sit-for waitsecs) + (unless (accept-process-output nil waitsecs nil nil) + (geiser-con--process-next con) (setq time (- time step)))) (error (setq time 0))) (or (> time 0) |