summaryrefslogtreecommitdiff
path: root/2d/repl/repl.scm
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2014-03-08 17:54:39 -0500
committerDavid Thompson <dthompson2@worcester.edu>2014-03-08 17:54:39 -0500
commit6a60f02c94d1131e78c7f76243077f8aaff6056a (patch)
treece717753a14acd8f2a0d2de58440066002814f65 /2d/repl/repl.scm
parent6dcbbb60d29408e6db804cb5b8bca3c4971055dc (diff)
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.
Diffstat (limited to '2d/repl/repl.scm')
-rw-r--r--2d/repl/repl.scm283
1 files changed, 0 insertions, 283 deletions
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)))))))