diff options
Diffstat (limited to '2d')
| -rw-r--r-- | 2d/repl.scm | 34 | ||||
| -rw-r--r-- | 2d/repl/repl.scm | 283 | ||||
| -rw-r--r-- | 2d/repl/server.scm | 132 |
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)) |