Integrate cooperative REPL server.

* 2d/repl.scm: New file.
* 2d/repl/repl.scm: Delete it.
* 2d/repl/server.scm: Delete it.
* Makfile.am (REPL_SOURCES): Delete it.
  (SOURCES): Add '2d/repl.scm'.
* examples/common.scm: Use cooperative REPL module.

3 files changed, 34 insertions, 415 deletions

diff --git a/2d/repl.scm b/2d/repl.scm
new file mode 100644
index 0000000..ef60d20
--- /dev/null
+++ b/2d/repl.scm
@@ -0,0 +1,34 @@
+;;; guile-2d
+;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Guile-2d 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.
+;;;
+;;; Guile-2d 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 program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Cooperative REPL server extension.
+;;
+;;; Code:
+
+(define-module (2d repl)
+  #:use-module (system repl coop-server)
+  #:use-module (2d agenda)
+  #:use-module (2d game))
+
+(define server (spawn-coop-repl-server))
+
+(define (poll-server)
+  (poll-coop-repl-server server))
+
+(schedule-interval game-agenda poll-server 2)
diff --git a/2d/repl/repl.scm b/2d/repl/repl.scm
deleted file mode 100644
index 87c5477..0000000
--- a/2d/repl/repl.scm
+++ /dev/null
@@ -1,283 +0,0 @@
-;;; Read-Eval-Print Loop
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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 (2d repl repl)
-  #:use-module (system base syntax)
-  #:use-module (system base pmatch)
-  #:use-module (system base compile)
-  #:use-module (system base language)
-  #:use-module (system vm vm)
-  #:use-module (system repl error-handling)
-  #:use-module (system repl common)
-  #:use-module (system repl command)
-  #:use-module (ice-9 control)
-  #:use-module (srfi srfi-2)
-  #:use-module (2d agenda)
-  #:use-module (2d game)
-  #:use-module (2d mvars)
-  #:export (start-repl
-            run-repl))
-
-
-;;;
-;;; Comments
-;;;
-;;; (You don't want a comment to force a continuation line.)
-;;;
-
-(define (read-scheme-line-comment port)
-  (let lp ()
-    (let ((ch (read-char port)))
-      (or (eof-object? ch)
-          (eqv? ch #\newline)
-          (lp)))))
-
-(define (read-scheme-datum-comment port)
-  (read port))
-
-;; ch is a peeked char
-(define (read-comment lang port ch)
-  (and (eq? (language-name lang) 'scheme)
-       (case ch
-         ((#\;)
-          (read-char port)
-          (read-scheme-line-comment port)
-          #t)
-         ((#\#)
-          (read-char port)
-          (case (peek-char port)
-            ((#\;)
-             (read-char port)
-             (read-scheme-datum-comment port)
-             #t)
-            ;; Not doing R6RS block comments because of the possibility
-            ;; of read-hash extensions.  Lame excuse.  Not doing scsh
-            ;; block comments either, because I don't feel like handling
-            ;; #!r6rs.
-            (else
-             (unread-char #\# port)
-             #f)))
-         (else
-          #f))))
-
-
-
-;;;
-;;; Meta commands
-;;;
-
-(define meta-command-token (cons 'meta 'command))
-
-(define (meta-reader lang env)
-  (lambda* (#:optional (port (current-input-port)))
-    (with-input-from-port port
-      (lambda ()
-        (let ((ch (flush-leading-whitespace)))
-          (cond ((eof-object? ch)
-                 (read-char))  ; consume the EOF and return it
-                ((eqv? ch #\,)
-                 (read-char)
-                 meta-command-token)
-                ((read-comment lang port ch)
-                 *unspecified*)
-                (else ((language-reader lang) port env))))))))
-
-(define (flush-all-input)
-  (if (and (char-ready?)
-           (not (eof-object? (peek-char))))
-      (begin
-        (read-char)
-        (flush-all-input))))
-
-;; repl-reader is a function defined in boot-9.scm, and is replaced by
-;; something else if readline has been activated. much of this hoopla is
-;; to be able to re-use the existing readline machinery.
-;;
-;; Catches read errors, returning *unspecified* in that case.
-(define (prompting-meta-read repl)
-  (catch #t
-    (lambda ()
-      (repl-reader (lambda () (repl-prompt repl))
-                   (meta-reader (repl-language repl) (current-module))))
-    (lambda (key . args)
-      (case key
-        ((quit)
-         (apply throw key args))
-        (else
-         (format (current-output-port) "While reading expression:\n")
-         (print-exception (current-output-port) #f key args)
-         (flush-all-input)
-         *unspecified*)))))
-
-
-
-;;;
-;;; guile-2d REPL stuff
-;;;
-
-(define repl-input-mvar  (new-empty-mvar))
-(define repl-output-mvar (new-empty-mvar))
-
-(define (run-repl-thunk thunk input output error stack)
-  "Run THUNK with the given REPL STACK. I/O is redirected to the given
-INPUT, OUTPUT, and ERROR ports."
-  (put-mvar
-   repl-output-mvar
-   (with-input-from-port input
-     (lambda ()
-       (with-output-to-port output
-         (lambda ()
-           (with-error-to-port error
-             (lambda ()
-               (with-fluids ((*repl-stack* stack))
-                 (thunk))))))))))
-
-(define (add-to-repl-mvar thunk input output error stack)
-  ;; Insert thunk into repl-mvar.  The game loop will schedule it and
-  ;; run it on the next tick.  We also pass along the
-  ;; input/output/error ports and the REPL stack.
-  (put-mvar repl-input-mvar (list thunk input output error stack))
-  ;; Read the results back from repl-output-mvar.  Will block until
-  ;; results are available.
-  (take-mvar repl-output-mvar))
-
-(define (flush-repl)
-  "Execute a thunk from the REPL is there is one."
-  (unless (mvar-empty? repl-input-mvar)
-    (and-let* ((vals (try-take-mvar repl-input-mvar)))
-              (apply run-repl-thunk vals))))
-
-(define poll-interval 5)
-
-(schedule-interval game-agenda flush-repl poll-interval)
-(schedule-interval paused-agenda flush-repl poll-interval)
-
-;;;
-;;; The repl
-;;;
-
-(define* (start-repl #:optional (lang (current-language)) #:key debug)
-  ;; ,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))))
-
-;; (put 'abort-on-error 'scheme-indent-function 1)
-(define-syntax-rule (abort-on-error string exp)
-  (catch #t
-    (lambda () exp)
-    (lambda (key . args)
-      (format #t "While ~A:~%" string)
-      (print-exception (current-output-port) #f key args)
-      (abort))))
-
-(define (run-repl repl)
-  (define (with-stack-and-prompt thunk)
-    (call-with-prompt (default-prompt-tag)
-                      (lambda () (start-stack #t (thunk)))
-                      (lambda (k proc)
-                        (with-stack-and-prompt (lambda () (proc k))))))
-
-  (% (with-fluids ((*repl-stack*
-                    (cons repl (or (fluid-ref *repl-stack*) '()))))
-       (if (null? (cdr (fluid-ref *repl-stack*)))
-           (repl-welcome repl))
-       (let prompt-loop ()
-         (let ((exp (prompting-meta-read repl)))
-           (cond
-            ((eqv? exp *unspecified*))  ; read error or comment, pass
-            ((eq? exp meta-command-token)
-             (catch #t
-               (lambda ()
-                 (add-to-repl-mvar
-                  (lambda ()
-                    (meta-command repl))
-                  (current-input-port)
-                  (current-output-port)
-                  (current-error-port)
-                  (fluid-ref *repl-stack*)))
-               (lambda (k . args)
-                 (if (eq? k 'quit)
-                     (abort args)
-                     (begin
-                       (format #t "While executing meta-command:~%")
-                       (print-exception (current-output-port) #f k args))))))
-            ((eof-object? exp)
-             (newline)
-             (abort '()))
-            (else
-             ;; since the input port is line-buffered, consume up to the
-             ;; newline
-             (flush-to-newline)
-             (call-with-error-handling
-              (lambda ()
-                (catch 'quit
-                  (lambda ()
-                    (call-with-values
-                        (lambda ()
-                          (% (let ((thunk
-                                    (abort-on-error "compiling expression"
-                                      (repl-prepare-eval-thunk
-                                       repl
-                                       (abort-on-error "parsing expression"
-                                         (repl-parse repl exp))))))
-                               (run-hook before-eval-hook exp)
-                               (add-to-repl-mvar
-                                (lambda ()
-                                  (call-with-error-handling
-                                   (lambda ()
-                                     (with-stack-and-prompt thunk))
-                                   #:on-error (repl-option-ref repl 'on-error)))
-                                (current-input-port)
-                                (current-output-port)
-                                (current-error-port)
-                                (fluid-ref *repl-stack*)))
-                             (lambda (k) (values))))
-                      (lambda l
-                        (for-each (lambda (v)
-                                    (repl-print repl v))
-                                  l))))
-                  (lambda (k . args)
-                    (run-hook after-eval-hook exp)
-                    (abort args))))
-              #:on-error (repl-option-ref repl 'on-error)
-              #:trap-handler 'disabled)))
-           (flush-to-newline) ;; consume trailing whitespace
-           (run-hook after-eval-hook exp)
-           (prompt-loop))))
-     (lambda (k status)
-       status)))
-
-;; Returns first non-whitespace char.
-(define (flush-leading-whitespace)
-  (let ((ch (peek-char)))
-    (cond ((eof-object? ch) ch)
-          ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
-          (else ch))))
-
-(define (flush-to-newline)
-  (if (char-ready?)
-      (let ((ch (peek-char)))
-        (if (and (not (eof-object? ch)) (char-whitespace? ch))
-            (begin
-              (read-char)
-              (if (not (char=? ch #\newline))
-                  (flush-to-newline)))))))
diff --git a/2d/repl/server.scm b/2d/repl/server.scm
deleted file mode 100644
index 9498b1d..0000000
--- a/2d/repl/server.scm
+++ /dev/null
@@ -1,132 +0,0 @@
-;;; Repl server
-
-;; Copyright (C)  2003, 2010, 2011 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 (2d repl server)
-  #:use-module (2d repl repl)
-  #:use-module (ice-9 threads)
-  #:export (make-tcp-server-socket
-            make-unix-domain-server-socket
-            run-server
-            spawn-server
-            stop-server-and-clients!))
-
-(define *open-sockets* '())
-
-(define sockets-lock (make-mutex))
-
-(define (close-socket! s)
-  (with-mutex sockets-lock
-    (set! *open-sockets* (delq! s *open-sockets*)))
-  ;; Close-port could block or raise an exception flushing buffered
-  ;; output.  Hmm.
-  (close-port s))
-
-(define (add-open-socket! s)
-  (with-mutex sockets-lock
-    (set! *open-sockets* (cons s *open-sockets*))))
-
-(define (stop-server-and-clients!)
-  (cond
-   ((with-mutex sockets-lock
-      (and (pair? *open-sockets*)
-           (car *open-sockets*)))
-    => (lambda (s)
-         (close-socket! s)
-         (stop-server-and-clients!)))))
-
-(define* (make-tcp-server-socket #:key
-                          (host #f)
-                          (addr (if host (inet-aton host) INADDR_LOOPBACK))
-                          (port 37146))
-  (let ((sock (socket PF_INET SOCK_STREAM 0)))
-    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-    (bind sock AF_INET addr port)
-    sock))
-
-(define* (make-unix-domain-server-socket #:key (path "/tmp/guile-socket"))
-  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
-    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-    (bind sock AF_UNIX path)
-    sock))
-
-(define call-with-sigint
-  (if (not (provided? 'posix))
-      (lambda (thunk) (thunk))
-      (lambda (thunk)
-        (let ((handler #f))
-          (dynamic-wind
-            (lambda ()
-              (set! handler
-                    (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
-            thunk
-            (lambda ()
-              (if handler
-                  ;; restore Scheme handler, SIG_IGN or SIG_DFL.
-                  (sigaction SIGINT (car handler) (cdr handler))
-                  ;; restore original C handler.
-                  (sigaction SIGINT #f))))))))
-
-(define* (run-server #:optional (server-socket (make-tcp-server-socket)))
-  (define (accept-new-client)
-    (catch #t
-      (lambda () (call-with-sigint (lambda () (accept server-socket))))
-      (lambda (k . args)
-        (cond
-         ((port-closed? server-socket)
-          ;; Shutting down.
-          #f)
-         ((eq? k 'interrupt)
-          ;; Interrupt.
-          (close-socket! server-socket)
-          #f)
-         (else
-          (warn "Error accepting client" k args)
-          ;; Retry after a timeout.
-          (sleep 1)
-          (accept-new-client))))))
-
-  (sigaction SIGPIPE SIG_IGN)
-  (add-open-socket! server-socket)
-  (listen server-socket 5)
-  (let lp ((client (accept-new-client)))
-    ;; If client is false, we are shutting down.
-    (if client
-        (let ((client-socket (car client))
-              (client-addr (cdr client)))
-          (add-open-socket! client-socket)
-          (make-thread serve-client client-socket client-addr)
-          (lp (accept-new-client))))))
-
-(define* (spawn-server #:optional (server-socket (make-tcp-server-socket)))
-  (make-thread run-server server-socket))
-
-(define (serve-client client addr)
-  (with-continuation-barrier
-   (lambda ()
-     (with-input-from-port client
-       (lambda ()
-         (with-output-to-port client
-           (lambda ()
-             (with-error-to-port client
-               (lambda ()
-                 (with-fluids ((*repl-stack* '()))
-                   (start-repl))))))))))
-  (close-socket! client))