module/system/repl/repl.scm

   1 ;;; Read-Eval-Print Loop
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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 ;;; Comments
  37 ;;;
  38 ;;; (You don't want a comment to force a continuation line.)
  39 ;;;
  40
  41 (define (read-scheme-line-comment port)
  42   (let lp ()
  43     (let ((ch (read-char port)))
  44       (or (eof-object? ch)
  45           (eqv? ch #\newline)
  46           (lp)))))
  47
  48 (define (read-scheme-datum-comment port)
  49   (read port))
  50
  51 ;; ch is a peeked char
  52 (define (read-comment lang port ch)
  53   (and (eq? (language-name lang) 'scheme)
  54        (case ch
  55          ((#\;)
  56           (read-char port)
  57           (read-scheme-line-comment port)
  58           #t)
  59          ((#\#)
  60           (read-char port)
  61           (case (peek-char port)
  62             ((#\;)
  63              (read-char port)
  64              (read-scheme-datum-comment port)
  65              #t)
  66             ;; Not doing R6RS block comments because of the possibility
  67             ;; of read-hash extensions.  Lame excuse.  Not doing scsh
  68             ;; block comments either, because I don't feel like handling
  69             ;; #!r6rs.
  70             (else
  71              (unread-char #\# port)
  72              #f)))
  73          (else
  74           #f))))
  75
  76 \f
  77
  78 ;;;
  79 ;;; Meta commands
  80 ;;;
  81
  82 (define meta-command-token (cons 'meta 'command))
  83
  84 (define (meta-reader lang env)
  85   (lambda* (#:optional (port (current-input-port)))
  86     (with-input-from-port port
  87       (lambda ()
  88         (let ((ch (flush-leading-whitespace)))
  89           (cond ((eof-object? ch)
  90                  (read-char))  ; consume the EOF and return it
  91                 ((eqv? ch #\,)
  92                  (read-char)
  93                  meta-command-token)
  94                 ((read-comment lang port ch)
  95                  *unspecified*)
  96                 (else ((language-reader lang) port env))))))))
  97
  98 (define (flush-all-input)
  99   (if (and (char-ready?)
 100            (not (eof-object? (peek-char))))
 101       (begin
 102         (read-char)
 103         (flush-all-input))))
 104
 105 ;; repl-reader is a function defined in boot-9.scm, and is replaced by
 106 ;; something else if readline has been activated. much of this hoopla is
 107 ;; to be able to re-use the existing readline machinery.
 108 ;;
 109 ;; Catches read errors, returning *unspecified* in that case.
 110 (define (prompting-meta-read repl)
 111   (catch #t
 112     (lambda ()
 113       (repl-reader (lambda () (repl-prompt repl))
 114                    (meta-reader (repl-language repl) (current-module))))
 115     (lambda (key . args)
 116       (case key
 117         ((quit)
 118          (apply throw key args))
 119         (else
 120          (format (current-output-port) "While reading expression:\n")
 121          (print-exception (current-output-port) #f key args)
 122          (flush-all-input)
 123          *unspecified*)))))
 124
 125 \f
 126
 127 ;;;
 128 ;;; The repl
 129 ;;;
 130
 131 (define* (start-repl #:optional (lang (current-language)) #:key debug)
 132   ;; ,language at the REPL will update the current-language.  Make
 133   ;; sure that it does so in a new dynamic scope.
 134   (parameterize ((current-language lang))
 135     (run-repl (make-repl lang debug))))
 136
 137 ;; (put 'abort-on-error 'scheme-indent-function 1)
 138 (define-syntax-rule (abort-on-error string exp)
 139   (catch #t
 140     (lambda () exp)
 141     (lambda (key . args)
 142       (format #t "While ~A:~%" string)
 143       (print-exception (current-output-port) #f key args)
 144       (abort))))
 145
 146 (define (run-repl repl)
 147   (define (with-stack-and-prompt thunk)
 148     (call-with-prompt (default-prompt-tag)
 149                       (lambda () (start-stack #t (thunk)))
 150                       (lambda (k proc)
 151                         (with-stack-and-prompt (lambda () (proc k))))))
 152
 153   (% (with-fluids ((*repl-stack*
 154                     (cons repl (or (fluid-ref *repl-stack*) '()))))
 155        (if (null? (cdr (fluid-ref *repl-stack*)))
 156            (repl-welcome repl))
 157        (let prompt-loop ()
 158          (let ((exp (prompting-meta-read repl)))
 159            (cond
 160             ((eqv? exp *unspecified*))  ; read error or comment, pass
 161             ((eq? exp meta-command-token)
 162              (catch #t
 163                (lambda ()
 164                  (meta-command repl))
 165                (lambda (k . args)
 166                  (if (eq? k 'quit)
 167                      (abort args)
 168                      (begin
 169                        (format #t "While executing meta-command:~%")
 170                        (print-exception (current-output-port) #f k args))))))
 171             ((eof-object? exp)
 172              (newline)
 173              (abort '()))
 174             (else
 175              ;; since the input port is line-buffered, consume up to the
 176              ;; newline
 177              (flush-to-newline)
 178              (call-with-error-handling
 179               (lambda ()
 180                 (catch 'quit
 181                   (lambda ()
 182                     (call-with-values
 183                         (lambda ()
 184                           (% (let ((thunk
 185                                     (abort-on-error "compiling expression"
 186                                       (repl-prepare-eval-thunk
 187                                        repl
 188                                        (abort-on-error "parsing expression"
 189                                          (repl-parse repl exp))))))
 190                                (run-hook before-eval-hook exp)
 191                                (call-with-error-handling
 192                                 (lambda ()
 193                                   (with-stack-and-prompt thunk))
 194                                 #:on-error (repl-option-ref repl 'on-error)))
 195                              (lambda (k) (values))))
 196                       (lambda l
 197                         (for-each (lambda (v)
 198                                     (repl-print repl v))
 199                                   l))))
 200                   (lambda (k . args)
 201                     (abort args))))
 202               #:on-error (repl-option-ref repl 'on-error)
 203               #:trap-handler 'disabled)))
 204            (flush-to-newline) ;; consume trailing whitespace
 205            (prompt-loop))))
 206      (lambda (k status)
 207        status)))
 208
 209 ;; Returns first non-whitespace char.
 210 (define (flush-leading-whitespace)
 211   (let ((ch (peek-char)))
 212     (cond ((eof-object? ch) ch)
 213           ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
 214           (else ch))))
 215
 216 (define (flush-to-newline)
 217   (if (char-ready?)
 218       (let ((ch (peek-char)))
 219         (if (and (not (eof-object? ch)) (char-whitespace? ch))
 220             (begin
 221               (read-char)
 222               (if (not (char=? ch #\newline))
 223                   (flush-to-newline)))))))