module/system/repl/repl.scm

   1 ;;; Read-Eval-Print Loop
   2
   3 ;; Copyright (C) 2001, 2009, 2010 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 vm vm)
  28   #:use-module (system repl error-handling)
  29   #:use-module (system repl common)
  30   #:use-module (system repl command)
  31   #:use-module (ice-9 control)
  32   #:export (start-repl run-repl))
  33
  34 \f
  35
  36 ;;;
  37 ;;; Meta commands
  38 ;;;
  39
  40 (define meta-command-token (cons 'meta 'command))
  41
  42 (define (meta-reader read env)
  43   (lambda read-args
  44     (let ((port (if (pair? read-args) (car read-args) (current-input-port))))
  45       (with-input-from-port port
  46         (lambda ()
  47           (let ((ch (next-char #t)))
  48             (cond ((eof-object? ch)
  49                    ;; apparently sometimes even if this is eof, read will
  50                    ;; wait on somethingorother. strange.
  51                    ch)
  52                   ((eqv? ch #\,)
  53                    (read-char port)
  54                    meta-command-token)
  55                   (else (read port env)))))))))
  56
  57 ;; repl-reader is a function defined in boot-9.scm, and is replaced by
  58 ;; something else if readline has been activated. much of this hoopla is
  59 ;; to be able to re-use the existing readline machinery.
  60 ;;
  61 ;; Catches read errors, returning *unspecified* in that case.
  62 (define (prompting-meta-read repl)
  63   (catch #t
  64     (lambda ()
  65       (repl-reader (lambda () (repl-prompt repl))
  66                    (meta-reader (language-reader (repl-language repl))
  67                                 (current-module))))
  68     (lambda (key . args)
  69       (case key
  70         ((quit)
  71          (apply throw key args))
  72         (else
  73          (pmatch args
  74            ((,subr ,msg ,args . ,rest)
  75             (format #t "Throw to key `~a' while reading expression:\n" key)
  76             (display-error #f (current-output-port) subr msg args rest))
  77            (else
  78             (format #t "Throw to key `~a' with args `~s' while reading expression.\n"
  79                     key args)))
  80          (force-output)
  81          *unspecified*)))))
  82
  83 \f
  84
  85 ;;;
  86 ;;; The repl
  87 ;;;
  88
  89 (define* (start-repl #:optional (lang (current-language)) #:key debug)
  90   (run-repl (make-repl lang debug)))
  91
  92 ;; (put 'abort-on-error 'scheme-indent-function 1)
  93 (define-syntax abort-on-error
  94   (syntax-rules ()
  95     ((_ string exp)
  96      (catch #t
  97        (lambda () exp)
  98        (lambda (key . args)
  99          (format #t "While ~A:~%" string)
 100          (pmatch args
 101            ((,subr ,msg ,args . ,rest)
 102             (display-error #f (current-output-port) subr msg args rest))
 103            (else
 104             (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args)))
 105          (force-output)
 106          (abort))))))
 107
 108 (define (run-repl repl)
 109   (define (with-stack-and-prompt thunk)
 110     (call-with-prompt (default-prompt-tag)
 111                       (lambda () (start-stack #t (thunk)))
 112                       (lambda (k proc)
 113                         (with-stack-and-prompt (lambda () (proc k))))))
 114
 115   (% (with-fluids ((*repl-stack*
 116                     (cons repl (or (fluid-ref *repl-stack*) '()))))
 117        (if (null? (cdr (fluid-ref *repl-stack*)))
 118            (repl-welcome repl))
 119        (let prompt-loop ()
 120          (let ((exp (prompting-meta-read repl)))
 121            (cond
 122             ((eqv? exp *unspecified*))  ; read error, pass
 123             ((eq? exp meta-command-token)
 124              (catch #t
 125                (lambda ()
 126                  (meta-command repl))
 127                (lambda (k . args)
 128                  (if (eq? k 'quit)
 129                      (abort args)
 130                      (begin
 131                        (format #t "While executing meta-command:~%" string)
 132                        (pmatch args
 133                          ((,subr ,msg ,args . ,rest)
 134                           (display-error #f (current-output-port) subr msg args rest))
 135                          (else
 136                           (format #t "ERROR: Throw to key `~a' with args `~s'.\n" k args)))
 137                        (force-output))))))
 138             ((eof-object? exp)
 139              (newline)
 140              (abort '()))
 141             (else
 142              ;; since the input port is line-buffered, consume up to the
 143              ;; newline
 144              (flush-to-newline)
 145              (call-with-error-handling
 146               (lambda ()
 147                 (catch 'quit
 148                   (lambda ()
 149                     (call-with-values
 150                         (lambda ()
 151                           (% (let ((thunk
 152                                     (abort-on-error "compiling expression"
 153                                       (repl-prepare-eval-thunk
 154                                        repl
 155                                        (abort-on-error "parsing expression"
 156                                          (repl-parse repl exp))))))
 157                                (run-hook before-eval-hook exp)
 158                                (with-error-handling
 159                                  (with-stack-and-prompt thunk)))
 160                              (lambda (k) (values))))
 161                       (lambda l
 162                         (for-each (lambda (v)
 163                                     (repl-print repl v))
 164                                   l))))
 165                   (lambda (k . args)
 166                     (abort args))))
 167               #:trap-handler 'disabled)))
 168            (next-char #f) ;; consume trailing whitespace
 169            (prompt-loop))))
 170      (lambda (k status)
 171        status)))
 172
 173 (define (next-char wait)
 174   (if (or wait (char-ready?))
 175       (let ((ch (peek-char)))
 176         (cond ((eof-object? ch) ch)
 177               ((char-whitespace? ch) (read-char) (next-char wait))
 178               (else ch)))
 179       #f))
 180
 181 (define (flush-to-newline)
 182   (if (char-ready?)
 183       (let ((ch (peek-char)))
 184         (if (and (not (eof-object? ch)) (char-whitespace? ch))
 185             (begin
 186               (read-char)
 187               (if (not (char=? ch #\newline))
 188                   (flush-to-newline)))))))