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 core)
  30   :use-module (ice-9 rdelim)
  31   :export (start-repl))
  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         (if (eqv? (next-char #t) #\,)
  41             (begin (read-char) meta-command-token)
  42             (read))))))
  43
  44 ;; repl-reader is a function defined in boot-9.scm, and is replaced by
  45 ;; something else if readline has been activated. much of this hoopla is
  46 ;; to be able to re-use the existing readline machinery.
  47 (define (prompting-meta-read repl)
  48   (let ((prompt (lambda () (repl-prompt repl)))
  49         (lread (language-reader (repl-language repl))))
  50     (with-fluid* current-reader (meta-reader lread)
  51       (lambda () (repl-reader (lambda () (repl-prompt repl)))))))
  52
  53 (define (default-pre-unwind-handler key . args)
  54   (save-stack default-pre-unwind-handler)
  55   (apply throw key args))
  56
  57 (define (default-catch-handler . args)
  58   (pmatch args
  59     ((quit . _)
  60      (apply throw args))
  61     ((vm-error ,fun ,msg ,args)
  62      (display "VM error: ")
  63      (apply format #t msg args)
  64      (newline))
  65     ((,key ,subr ,msg ,args . ,rest)
  66      (let ((cep (current-error-port)))
  67        (cond ((not (stack? (fluid-ref the-last-stack))))
  68              ((memq 'backtrace (debug-options-interface))
  69               (let ((highlights (if (or (eq? key 'wrong-type-arg)
  70                                         (eq? key 'out-of-range))
  71                                     (car rest)
  72                                     '())))
  73                 (run-hook before-backtrace-hook)
  74                 (newline cep)
  75                 (display "Backtrace:\n")
  76                 (display-backtrace (fluid-ref the-last-stack) cep
  77                                    #f #f highlights)
  78                 (newline cep)
  79                 (run-hook after-backtrace-hook))))
  80        (run-hook before-error-hook)
  81        (apply display-error (fluid-ref the-last-stack) cep subr msg args rest)
  82        (run-hook after-error-hook)
  83        (set! stack-saved? #f)
  84        (force-output cep)))
  85     (else
  86      (apply bad-throw args))))
  87
  88 (eval-case
  89  ((compile-toplevel)
  90   (define-macro (start-stack tag expr)
  91     expr)))
  92
  93 (define (start-repl lang)
  94   (let ((repl (make-repl lang)))
  95     (repl-welcome repl)
  96     (let prompt-loop ()
  97       (let ((exp (prompting-meta-read repl)))
  98         (cond
  99          ((eq? exp meta-command-token)
 100           (meta-command repl (read-line)))
 101          ((eof-object? exp)
 102           (throw 'quit))
 103          (else
 104           (catch #t
 105                  (lambda ()
 106                    (call-with-values (lambda ()
 107                                        (run-hook before-eval-hook exp)
 108                                        (start-stack repl-eval
 109                                                     (repl-eval repl exp)))
 110                      (lambda l
 111                        (for-each (lambda (v)
 112                                    (run-hook before-print-hook v)
 113                                    (repl-print repl v))
 114                                  l))))
 115                  default-catch-handler
 116                  default-pre-unwind-handler)))
 117         (next-char #f) ;; consume trailing whitespace
 118         (prompt-loop)))))
 119
 120 (define (next-char wait)
 121   (if (or wait (char-ready?))
 122       (let ((ch (peek-char)))
 123         (cond ((eof-object? ch) (throw 'quit))
 124               ((char-whitespace? ch) (read-char) (next-char wait))
 125               (else ch)))
 126       #f))