module/system/repl/repl.scm

   1 ;;; Read-Eval-Print Loop
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18 ;; 02110-1301 USA
  19
  20 ;;; Code:
  21
  22 (define-module (system repl repl)
  23   #:use-module (system base syntax)
  24   #:use-module (system base pmatch)
  25   #:use-module (system base compile)
  26   #:use-module (system base language)
  27   #:use-module (system repl common)
  28   #:use-module (system repl command)
  29   #:use-module (system vm vm)
  30   #:use-module (system vm debug)
  31   #:export (start-repl call-with-backtrace))
  32
  33 (define meta-command-token (cons 'meta 'command))
  34
  35 (define (meta-reader read)
  36   (lambda read-args
  37     (with-input-from-port
  38         (if (pair? read-args) (car read-args) (current-input-port))
  39       (lambda ()
  40         (let ((ch (next-char #t)))
  41           (cond ((eof-object? ch)
  42                  ;; apparently sometimes even if this is eof, read will
  43                  ;; wait on somethingorother. strange.
  44                  ch)
  45                 ((eqv? ch #\,)
  46                  (read-char)
  47                  meta-command-token)
  48                 (else (read))))))))
  49
  50 ;; repl-reader is a function defined in boot-9.scm, and is replaced by
  51 ;; something else if readline has been activated. much of this hoopla is
  52 ;; to be able to re-use the existing readline machinery.
  53 (define (prompting-meta-read repl)
  54   (let ((prompt (lambda () (repl-prompt repl)))
  55         (lread (language-reader (repl-language repl))))
  56     (with-fluid* current-reader (meta-reader lread)
  57       (lambda () (repl-reader (lambda () (repl-prompt repl)))))))
  58
  59 (define (default-catch-handler . args)
  60   (pmatch args
  61     ((quit . _)
  62      (apply throw args))
  63     ((,key ,subr ,msg ,args . ,rest)
  64      (let ((cep (current-error-port)))
  65        (cond ((not (stack? (fluid-ref the-last-stack))))
  66              ((memq 'backtrace (debug-options-interface))
  67               (let ((highlights (if (or (eq? key 'wrong-type-arg)
  68                                         (eq? key 'out-of-range))
  69                                     (car rest)
  70                                     '())))
  71                 (run-hook before-backtrace-hook)
  72                 (newline cep)
  73                 (display "Backtrace:\n")
  74                 (display-backtrace (fluid-ref the-last-stack) cep
  75                                    #f #f highlights)
  76                 (newline cep)
  77                 (run-hook after-backtrace-hook))))
  78        (run-hook before-error-hook)
  79        (display-error (fluid-ref the-last-stack) cep subr msg args rest)
  80        (run-hook after-error-hook)
  81        (set! stack-saved? #f)
  82        (force-output cep)))
  83     (else
  84      (format (current-error-port) "\nERROR: uncaught throw to `~a', args: ~a\n"
  85              (car args) (cdr args)))))
  86
  87 (define (call-with-backtrace thunk)
  88   (catch #t
  89          (lambda () (%start-stack #t thunk))
  90          default-catch-handler
  91          default-pre-unwind-handler))
  92
  93 (define-macro (with-backtrace form)
  94   `(call-with-backtrace (lambda () ,form)))
  95
  96 (define (start-repl lang)
  97   (let ((repl (make-repl lang))
  98         (status #f))
  99     (repl-welcome repl)
 100     (let prompt-loop ()
 101       (let ((exp (with-backtrace (prompting-meta-read repl))))
 102         (cond
 103          ((eqv? exp (if #f #f))) ; read error, pass
 104          ((eq? exp meta-command-token)
 105           (with-backtrace (meta-command repl)))
 106          ((eof-object? exp)
 107           (newline)
 108           (set! status '()))
 109          (else
 110           ;; since the input port is line-buffered, consume up to the
 111           ;; newline
 112           (flush-to-newline)
 113           (with-backtrace
 114            (catch 'quit
 115                   (lambda ()
 116                     (call-with-values
 117                         (lambda ()
 118                           (run-hook before-eval-hook exp)
 119                           (start-stack #t
 120                                        (repl-eval repl (repl-parse repl exp))))
 121                       (lambda l
 122                         (for-each (lambda (v)
 123                                     (run-hook before-print-hook v)
 124                                     (repl-print repl v))
 125                                   l))))
 126                   (lambda (k . args)
 127                     (set! status args))))))
 128         (or status
 129             (begin
 130               (next-char #f) ;; consume trailing whitespace
 131               (prompt-loop)))))))
 132
 133 (define (next-char wait)
 134   (if (or wait (char-ready?))
 135       (let ((ch (peek-char)))
 136         (cond ((eof-object? ch) ch)
 137               ((char-whitespace? ch) (read-char) (next-char wait))
 138               (else ch)))
 139       #f))
 140
 141 (define (flush-to-newline)
 142   (if (char-ready?)
 143       (let ((ch (peek-char)))
 144         (if (and (not (eof-object? ch)) (char-whitespace? ch))
 145             (begin
 146               (read-char)
 147               (if (not (char=? ch #\newline))
 148                   (flush-to-newline)))))))
 149
 150