diff options
| -rw-r--r-- | 2d/repl/repl.scm | 225 | ||||
| -rw-r--r-- | 2d/repl/server.scm | 132 |
2 files changed, 357 insertions, 0 deletions
diff --git a/2d/repl/repl.scm b/2d/repl/repl.scm new file mode 100644 index 0000000..433e0e7 --- /dev/null +++ b/2d/repl/repl.scm @@ -0,0 +1,225 @@ +;;; 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) + #: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*))))) + + + +;;; +;;; 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 () + (meta-command repl)) + (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) + (call-with-error-handling + (lambda () + (with-stack-and-prompt thunk)) + #:on-error (repl-option-ref repl 'on-error))) + (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 new file mode 100644 index 0000000..9498b1d --- /dev/null +++ b/2d/repl/server.scm @@ -0,0 +1,132 @@ +;;; 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)) |