module/system/repl/repl.scm

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