From 7e183c5316ab997041cf6ec83192e7a32e49e0fa Mon Sep 17 00:00:00 2001
From: David Thompson
Date: Sun, 19 Jan 2014 13:16:02 -0500
Subject: [PATCH] Add cooperative REPL server module.
* module/system/repl/coop-server.scm: New module.
* module/system/repl/repl.scm (start-repl): Extract body to start-repl*.
(start-repl*): New procedure.
* module/system/repl/server.scm (run-server): Extract body to
run-server*.
(run-server*): New procedure.
* doc/ref/api-evaluation.texi: Add docs.
---
doc/ref/api-evaluation.texi | 47 +++++++++++
module/Makefile.am | 3 +-
module/system/repl/coop-server.scm | 163 +++++++++++++++++++++++++++++++++++++
module/system/repl/repl.scm | 11 ++-
module/system/repl/server.scm | 5 +-
5 files changed, 223 insertions(+), 6 deletions(-)
create mode 100644 module/system/repl/coop-server.scm
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 63b1d60..d366aa1 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -23,6 +23,7 @@ loading, evaluating, and compiling Scheme code at run time.
* Local Evaluation:: Evaluation in a local lexical environment.
* Local Inclusion:: Compile-time inclusion of one file in another.
* REPL Servers:: Serving a REPL over a socket.
+* Cooperative REPL Servers:: REPL server for single-threaded applications.
@end menu
@@ -1275,6 +1276,52 @@ with no arguments.
Closes the connection on all running server sockets.
@end deffn
address@hidden Cooperative REPL Servers
address@hidden Cooperative REPL Servers
+
address@hidden Cooperative REPL server
+
+The procedures in this section are provided by
address@hidden
+(use-modules (system repl coop-server))
address@hidden lisp
+
+Whereas REPL servers run in their own threads, sometimes it is more
+convenient to provide REPLs that run at specified times within an
+existing thread, for example in programs utilizing an event loop or in
+single-threaded programs. This allows for safe access and mutation of a
+program's data structures from the REPL, without concern for thread
+synchronization. The server must be polled periodically to evaluate any
+pending expressions.
+
address@hidden {Scheme Procedure} make-coop-repl-server
+Return a newly allocated cooperative REPL server.
address@hidden deffn
+
address@hidden {Scheme Procedure} coop-repl-server? obj
+Return @code{#t} if @var{obj} is a cooperative REPL server, otherwise
+return @code{#f}.
address@hidden deffn
+
address@hidden {Scheme Procedure} run-coop-repl-server coop-server [server-socket]
+Run the given cooperative REPL server @var{coop-server} in the current
+thread, making it available over the given @var{server-socket}. If
address@hidden is not provided, it defaults to the socket created
+by calling @code{make-tcp-server-socket} with no arguments.
address@hidden deffn
+
address@hidden {Scheme Procedure} spawn-coop-repl-server [server-socket]
+Return a newly allocated cooperative REPL server and run the server in a
+new thread, making it available over the given @var{server-socket}. If
address@hidden is not provided, it defaults to the socket created
+by calling @code{make-tcp-server-socket} with no arguments.
address@hidden deffn
+
address@hidden {Scheme Procedure} poll-coop-repl-server coop-server
+Poll the cooperative REPL server COOP-SERVER and evaluate a pending
+expression if there is one.
address@hidden deffn
+
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/module/Makefile.am b/module/Makefile.am
index 8a7befd..b7960dc 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -360,7 +360,8 @@ SYSTEM_SOURCES = \
system/repl/common.scm \
system/repl/command.scm \
system/repl/repl.scm \
- system/repl/server.scm
+ system/repl/server.scm \
+ system/repl/coop-server.scm
LIB_SOURCES = \
statprof.scm \
diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm
new file mode 100644
index 0000000..466b8ae
--- /dev/null
+++ b/module/system/repl/coop-server.scm
@@ -0,0 +1,163 @@
+;;; Cooperative REPL server
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl coop-server)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 mvars)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 threads)
+ #:use-module (srfi srfi-9)
+ #:use-module ((system repl repl)
+ #:select (start-repl* prompting-meta-read))
+ #:use-module ((system repl server)
+ #:select (run-server* make-tcp-server-socket close-socket!))
+ #:use-module (system repl error-handling)
+ #:export (make-coop-repl-server
+ coop-repl-server?
+ run-coop-repl-server
+ spawn-coop-repl-server
+ poll-coop-repl-server))
+
+(define-record-type
+ (%make-coop-repl-server eval-mvar)
+ coop-repl-server?
+ (eval-mvar coop-repl-server-eval-mvar))
+
+(define (make-coop-repl-server)
+ (%make-coop-repl-server (new-empty-mvar)))
+
+(define (coop-repl-server-eval coop-server opcode . args)
+ "Put a new instruction with the symbolic name OPCODE and an arbitrary
+number of arguments into the evaluation mvar of COOP-SERVER."
+ (put-mvar (coop-repl-server-eval-mvar coop-server)
+ (cons opcode args)))
+
+(define-record-type
+ (%make-coop-repl read-mvar cont)
+ coop-repl?
+ (read-mvar coop-repl-read-mvar)
+ (cont coop-repl-cont set-coop-repl-cont!))
+
+(define (make-coop-repl)
+ (%make-coop-repl (new-empty-mvar) #f))
+
+(define (coop-repl-read coop-repl)
+ "Read an expression via the thunk stored in COOP-REPL."
+ ((take-mvar (coop-repl-read-mvar coop-repl))))
+
+(define (store-repl-cont cont coop-repl)
+ "Save the partial continuation CONT within COOP-REPL."
+ (set-coop-repl-cont! coop-repl
+ (lambda (exp)
+ (coop-repl-prompt
+ (lambda () (cont exp))))))
+
+(define (coop-repl-prompt thunk)
+ "Apply THUNK within a prompt for cooperative REPLs."
+ (call-with-prompt 'coop-repl-prompt thunk store-repl-cont))
+
+(define (make-coop-reader coop-repl)
+ "Return a new procedure for reading user input from COOP-REPL. The
+generated procedure passes the responsibility of reading input to
+another thread via an mvar and aborts the cooperative REPL prompt."
+ (lambda (repl)
+ (put-mvar (coop-repl-read-mvar coop-repl)
+ ;; Need to preserve the REPL stack and current module across
+ ;; threads.
+ (let ((stack (fluid-ref *repl-stack*))
+ (module (current-module)))
+ (lambda ()
+ (with-fluids ((*repl-stack* stack))
+ (set-current-module module)
+ (prompting-meta-read repl)))))
+ (abort-to-prompt 'coop-repl-prompt coop-repl)))
+
+(define (reader-loop coop-server coop-repl)
+ "Run an unbounded loop that reads an expression for COOP-REPL and
+stores the expression within COOP-SERVER for later evaluation."
+ (coop-repl-server-eval coop-server 'eval coop-repl
+ (coop-repl-read coop-repl))
+ (reader-loop coop-server coop-repl))
+
+(define (poll-coop-repl-server coop-server)
+ "Test if there is an expression waiting to be evaluated within
+COOP-SERVER and evaluate it if so."
+ (receive (op success?)
+ (try-take-mvar (coop-repl-server-eval-mvar coop-server))
+ (when success?
+ (match op
+ (('new-repl client)
+ (start-repl-client coop-server client))
+ (('eval coop-repl exp)
+ ((coop-repl-cont coop-repl) exp))))))
+
+(define* (start-coop-repl coop-server #:optional
+ (lang (current-language)) #:key debug)
+ "Start a new cooperative REPL process for COOP-SERVER using the
+language LANG."
+ ;; Calling stop-server-and-clients! from a REPL will cause an
+ ;; exception to be thrown when trying to read from the socket that has
+ ;; been closed, so we catch that here.
+ (false-if-exception
+ (let ((coop-repl (make-coop-repl)))
+ (make-thread reader-loop coop-server coop-repl)
+ (start-repl* lang debug (make-coop-reader coop-repl)))))
+
+(define* (run-coop-repl-server coop-server #:optional
+ (server-socket (make-tcp-server-socket)))
+ "Start the cooperative REPL server for COOP-SERVER using the socket
+SERVER-SOCKET."
+ (run-server* server-socket (make-coop-client-proc coop-server)))
+
+(define* (spawn-coop-repl-server
+ #:optional (server-socket (make-tcp-server-socket)))
+ "Return a newly allocated cooperative REPL server and run the server
+in a new thread, making it available over SERVER-SOCKET."
+ (let ((coop-server (make-coop-repl-server)))
+ (make-thread run-coop-repl-server
+ coop-server
+ server-socket)
+ coop-server))
+
+(define (make-coop-client-proc coop-server)
+ "Return a new procedure that is used to schedule the creation of a new
+cooperative REPL for COOP-SERVER."
+ (lambda (client addr)
+ (coop-repl-server-eval coop-server 'new-repl client)))
+
+(define (start-repl-client coop-server client)
+ "Run a cooperative REPL for COOP-SERVER within a prompt. All input
+and output is sent over the socket CLIENT."
+ (with-continuation-barrier
+ (lambda ()
+ (coop-repl-prompt
+ (lambda ()
+ (with-input-from-port client
+ (lambda ()
+ (with-output-to-port client
+ (lambda ()
+ (with-error-to-port client
+ (lambda ()
+ (with-fluids ((*repl-stack* '()))
+ (save-module-excursion
+ (lambda ()
+ (start-coop-repl coop-server))))))))))
+ (close-socket! client))))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 1649556..50a14a7 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -1,6 +1,6 @@
;;; Read-Eval-Print Loop
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013 2014 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -129,10 +129,13 @@
;;;
(define* (start-repl #:optional (lang (current-language)) #:key debug)
+ (start-repl* lang debug prompting-meta-read))
+
+(define (start-repl* lang debug reader)
;; ,language at the REPL will update the current-language. Make
;; sure that it does so in a new dynamic scope.
(parameterize ((current-language lang))
- (run-repl (make-repl lang debug))))
+ (run-repl (make-repl lang debug) reader)))
;; (put 'abort-on-error 'scheme-indent-function 1)
(define-syntax-rule (abort-on-error string exp)
@@ -143,7 +146,7 @@
(print-exception (current-output-port) #f key args)
(abort))))
-(define (run-repl repl)
+(define (run-repl repl reader)
(define (with-stack-and-prompt thunk)
(call-with-prompt (default-prompt-tag)
(lambda () (start-stack #t (thunk)))
@@ -155,7 +158,7 @@
(if (null? (cdr (fluid-ref *repl-stack*)))
(repl-welcome repl))
(let prompt-loop ()
- (let ((exp (prompting-meta-read repl)))
+ (let ((exp (reader repl)))
(cond
((eqv? exp *unspecified*)) ; read error or comment, pass
((eq? exp meta-command-token)
diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm
index ec90677..9b16c9f 100644
--- a/module/system/repl/server.scm
+++ b/module/system/repl/server.scm
@@ -1,6 +1,6 @@
;;; Repl server
-;; Copyright (C) 2003, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2010, 2011, 2014 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -85,6 +85,9 @@
(sigaction SIGINT #f))))))))
(define* (run-server #:optional (server-socket (make-tcp-server-socket)))
+ (run-server* server-socket serve-client))
+
+(define (run-server* server-socket serve-client)
(define (accept-new-client)
(catch #t
(lambda () (call-with-sigint (lambda () (accept server-socket))))
--
1.8.5.2