Add custom REPL server modules.

These are slightly modified versions of the ones that come with Guile.

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))