summaryrefslogtreecommitdiff
path: root/2d
diff options
context:
space:
mode:
Diffstat (limited to '2d')
-rw-r--r--2d/repl.scm34
-rw-r--r--2d/repl/repl.scm283
-rw-r--r--2d/repl/server.scm132
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))