From dc8155b5d0e5c533a1fc6cb64399e8cccd7c1716 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Fri, 12 Nov 2010 01:33:09 +0100 Subject: [PATCH] Guile reconnected (but not debuggable (yet)) Or the importance of EOL. Switching to a transaction queue for communication with the Scheme process means that i had to care about sending eols in the queries... Guile was waiting for ever reading a metacommand taking a variable number of arguments. Argh: this has taken me a few hours -- i'm getting old. --- elisp/geiser-guile.el | 37 +++++++++++++++++++++++-------------- elisp/geiser-racket.el | 1 - elisp/geiser-repl.el | 6 +++--- scheme/guile/geiser/emacs.scm | 23 +++++++++++++++++------ scheme/guile/geiser/evaluation.scm | 18 ++++-------------- 5 files changed, 47 insertions(+), 38 deletions(-) diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el index 3979688..1295bac 100644 --- a/elisp/geiser-guile.el +++ b/elisp/geiser-guile.el @@ -101,15 +101,14 @@ This function uses `geiser-guile-init-file' if it exists." (let ((init-file (and (stringp geiser-guile-init-file) (expand-file-name geiser-guile-init-file)))) `(,@(and (listp geiser-guile-binary) (cdr geiser-guile-binary)) - "-q" + "-q" "-L" ,(expand-file-name "guile/" geiser-scheme-dir) ,@(apply 'append (mapcar (lambda (p) (list "-L" p)) geiser-guile-load-path)) ,@(and init-file (file-readable-p init-file) (list "-l" init-file))))) -(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ") +;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ") +(defconst geiser-guile--prompt-regexp "[^@()]+@([^)]*?)> ") (defconst geiser-guile--debugger-prompt-regexp - "^[^() \n]+@([^)]*?) \\[[0-9]+\\]> ") -(defconst geiser-guile--debugger-preamble-regexp - "^Entering a new prompt\\. ") + "^[^@()]+@([^)]*?) \\[[0-9]+\\]> ") ;;; Evaluation support: @@ -118,7 +117,7 @@ This function uses `geiser-guile-init-file' if it exists." (defun geiser-guile--geiser-procedure (proc &rest args) (case proc - ((eval compile) (format ",geiser-eval %s %s%s" + ((eval compile) (format ",geiser-eval %s %s%s\n" (or (car args) "#f") (geiser-guile--linearize-args (cdr args)) (if (cddr args) "" " ()"))) @@ -248,7 +247,14 @@ it spawn a server thread." (interactive) (geiser-connect 'guile)) -(defun geiser-guile--startup () +(defun geiser-guile--load-path-string () + (let* ((path (expand-file-name "guile/" geiser-scheme-dir)) + (witness "geiser/emacs.scm") + (code `(if (not (%search-load-path ,witness)) + (set! %load-path (cons ,path %load-path))))) + (geiser-eval--scheme-str code))) + +(defun geiser-guile--startup (remote) (set (make-local-variable 'compilation-error-regexp-alist) `((,geiser-guile--path-rx geiser-guile--resolve-file-x) ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil 1 2))) @@ -256,23 +262,26 @@ it spawn a server thread." (font-lock-add-keywords nil `((,geiser-guile--path-rx 1 compilation-error-face))) - (geiser-eval--send/wait - (format "(set! %%load-path (cons %S %%load-path))" - (expand-file-name "guile/" geiser-scheme-dir))) - (geiser-eval--send/wait ",use (geiser emacs)") + (when remote + (geiser-eval--send/wait (concat (geiser-guile--load-path-string) "\n")) + (geiser-eval--send/wait ",use (geiser emacs)\n")) (geiser-guile-update-warning-level)) +(defconst geiser-guile--init-server-command + ",use (geiser emacs)\n,geiser-start-server") + ;;; Implementation definition: (define-geiser-implementation guile (binary geiser-guile--binary) (arglist geiser-guile--parameters) - (startup geiser-guile--startup) + (repl-startup geiser-guile--startup) (prompt-regexp geiser-guile--prompt-regexp) - (enter-debugger geiser-guile--enter-debugger) + (inferior-prompt-regexp geiser-guile--prompt-regexp) + (init-server-command geiser-guile--init-server-command) (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp) - (debugger-preamble-regexp geiser-guile--debugger-preamble-regexp) + (enter-debugger geiser-guile--enter-debugger) (marshall-procedure geiser-guile--geiser-procedure) (find-module geiser-guile--get-module) (enter-command geiser-guile--enter-command) diff --git a/elisp/geiser-racket.el b/elisp/geiser-racket.el index 4fd0952..f3aa7e5 100644 --- a/elisp/geiser-racket.el +++ b/elisp/geiser-racket.el @@ -244,7 +244,6 @@ using start-geiser, a procedure in the geiser/server module." (binary geiser-racket--binary) (arglist geiser-racket--parameters) (init-server-command geiser-racket--init-server-command) - (startup) (prompt-regexp geiser-racket--prompt-regexp) (marshall-procedure geiser-racket--geiser-procedure) (find-module geiser-racket--get-module) diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el index 9136db5..2117ff1 100644 --- a/elisp/geiser-repl.el +++ b/elisp/geiser-repl.el @@ -118,7 +118,7 @@ expression for this implementation's geiser scheme prompt.") "A variable (or thunk returning a value) giving the regular expression for this implementation's debugging prompt.") -(geiser-impl--define-caller geiser-repl--startup startup () +(geiser-impl--define-caller geiser-repl--startup repl-startup (remote) "Function taking no parameters that is called after the REPL has been initialised. All Geiser functionality is available to you at that point.") @@ -264,7 +264,7 @@ module command as a string") (geiser-repl--history-setup) (add-to-list 'geiser-repl--repls (current-buffer)) (geiser-repl--set-this-buffer-repl (current-buffer)) - (geiser-repl--startup impl) + (geiser-repl--startup impl remote) (message "%s up and running!" (geiser-repl--repl-name impl)))) (defun geiser-repl--connection () @@ -599,7 +599,7 @@ With a prefix argument, force exit by killing the scheme process." (with-current-buffer repl (push (cons geiser-impl--implementation (when geiser-repl--remote-p - (list geiser-repl--host geiser-repl--port))) + (list (geiser-repl--host) (geiser-repl--port)))) lst)))))) (defun geiser-repl--restore (impls) diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm index 54e5d34..9e3d410 100644 --- a/scheme/guile/geiser/emacs.scm +++ b/scheme/guile/geiser/emacs.scm @@ -13,6 +13,7 @@ #:use-module (ice-9 match) #:use-module (system repl command) #:use-module (system repl error-handling) + #:use-module (system repl server) #:use-module (geiser evaluation) #:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:)) #:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:)) @@ -26,8 +27,13 @@ No-op command used internally by Geiser." (values)) +(define-meta-command ((geiser-newline geiser) repl) + "geiser-newline +Meta-command used by Geiser to emit a new line." + (newline)) + (define-meta-command ((geiser-eval geiser) repl (mod form args) . rest) - "geiser-eval + "geiser-eval module form args () Meta-command used by Geiser to evaluate and compile code." (if (null? args) (call-with-error-handling @@ -36,12 +42,17 @@ Meta-command used by Geiser to evaluate and compile code." (ge:eval `(,proc ,@args) mod)))) (define-meta-command ((geiser-load-file geiser) repl file) - "geiser-load-file + "geiser-load-file file Meta-command used by Geiser to load and compile files." (call-with-error-handling (lambda () (ge:compile-file file)))) -(define-meta-command ((geiser-newline geiser) repl) - "geiser-newline -Meta-command used by Geiser to emit a new line." - (newline)) + +(define-meta-command ((geiser-start-server geiser) repl) + "geiser-start-server +Meta-command used by Geiser to start a REPL server." + (let* ((sock (make-tcp-server-socket #:port 0)) + (port (sockaddr:port (getsockname sock)))) + (spawn-server sock) + (write (list 'port port)) + (newline))) diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index ef082db..305ccfd 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -25,20 +25,6 @@ #:use-module (system vm program) #:use-module (ice-9 pretty-print)) -(define (handle-error stack . args) - (pmatch args - ((,key ,subr ,msg ,args . ,rest) - (display "Backtrace:\n") - (if (stack? stack) - (display-backtrace stack (current-output-port))) - (newline) - (display-error stack (current-output-port) subr msg args rest)) - (else (display (format "ERROR: ~a, args: ~a" (car args) (cdr args))))) - `(error (key . ,(car args)))) - -(define (write-result result output) - (write (list (cons 'result result) (cons 'output output))) - (newline)) (define compile-opts '()) (define compile-file-opts '()) @@ -62,6 +48,10 @@ (ge:set-warnings 'none) +(define (write-result result output) + (write (list (cons 'result result) (cons 'output output))) + (newline)) + (define (call-with-result thunk) (letrec* ((result #f) (output -- 2.11.4.GIT