summaryrefslogtreecommitdiff
path: root/2d/repl/repl.scm
diff options
context:
space:
mode:
Diffstat (limited to '2d/repl/repl.scm')
-rw-r--r--2d/repl/repl.scm225
1 files changed, 225 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)))))))