module/ice-9/scm-style-repl.scm

   1 ;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
   2 ;;;; Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 3 of the License, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This library is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;;; Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this library; if not, write to the Free Software
  16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17 ;;;;
  18
  19 (define-module (ice-9 scm-style-repl)
  20   #:export (scm-repl-silent
  21             scm-repl-print-unspecified
  22             scm-repl-verbose
  23             scm-repl-prompt)
  24
  25   ;; #:replace, as with deprecated code enabled these will be in the root env
  26   #:replace (assert-repl-silence
  27              assert-repl-print-unspecified
  28              assert-repl-verbosity
  29
  30              bad-throw
  31              error-catching-loop
  32              error-catching-repl
  33              scm-style-repl))
  34
  35 (define scm-repl-silent #f)
  36 (define (assert-repl-silence v) (set! scm-repl-silent v))
  37
  38 (define scm-repl-print-unspecified #f)
  39 (define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
  40
  41 (define scm-repl-verbose #f)
  42 (define (assert-repl-verbosity v) (set! scm-repl-verbose v))
  43
  44 (define scm-repl-prompt "guile> ")
  45
  46 \f
  47
  48 ;; bad-throw is the hook that is called upon a throw to a an unhandled
  49 ;; key (unless the throw has four arguments, in which case
  50 ;; it's usually interpreted as an error throw.)
  51 ;; If the key has a default handler (a throw-handler-default property),
  52 ;; it is applied to the throw.
  53 ;;
  54 (define (bad-throw key . args)
  55   (let ((default (symbol-property key 'throw-handler-default)))
  56     (or (and default (apply default key args))
  57         (apply error "unhandled-exception:" key args))))
  58
  59 \f
  60
  61 (define (error-catching-loop thunk)
  62   (let ((status #f)
  63         (interactive #t))
  64     (define (loop first)
  65       (let ((next
  66              (catch #t
  67
  68                     (lambda ()
  69                       (call-with-unblocked-asyncs
  70                        (lambda ()
  71                          (with-traps
  72                           (lambda ()
  73                             (first)
  74
  75                             ;; This line is needed because mark
  76                             ;; doesn't do closures quite right.
  77                             ;; Unreferenced locals should be
  78                             ;; collected.
  79                             (set! first #f)
  80                             (let loop ((v (thunk)))
  81                               (loop (thunk)))
  82                             #f)))))
  83
  84                     (lambda (key . args)
  85                       (case key
  86                         ((quit)
  87                          (set! status args)
  88                          #f)
  89
  90                         ((switch-repl)
  91                          (apply throw 'switch-repl args))
  92
  93                         ((abort)
  94                          ;; This is one of the closures that require
  95                          ;; (set! first #f) above
  96                          ;;
  97                          (lambda ()
  98                            (run-hook abort-hook)
  99                            (force-output (current-output-port))
 100                            (display "ABORT: "  (current-error-port))
 101                            (write args (current-error-port))
 102                            (newline (current-error-port))
 103                            (if interactive
 104                                (begin
 105                                  (if (and
 106                                       (not has-shown-debugger-hint?)
 107                                       (not (memq 'backtrace
 108                                                  (debug-options-interface)))
 109                                       (stack? (fluid-ref the-last-stack)))
 110                                      (begin
 111                                        (newline (current-error-port))
 112                                        (display
 113                                         "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
 114                                         (current-error-port))
 115                                        (set! has-shown-debugger-hint? #t)))
 116                                  (force-output (current-error-port)))
 117                                (begin
 118                                  (primitive-exit 1)))
 119                            (set! stack-saved? #f)))
 120
 121                         (else
 122                          ;; This is the other cons-leak closure...
 123                          (lambda ()
 124                            (cond ((= (length args) 4)
 125                                   (apply handle-system-error key args))
 126                                  (else
 127                                   (apply bad-throw key args)))))))
 128
 129                     default-pre-unwind-handler)))
 130
 131         (if next (loop next) status)))
 132     (set! ensure-batch-mode! (lambda ()
 133                                (set! interactive #f)
 134                                (restore-signals)))
 135     (set! batch-mode? (lambda () (not interactive)))
 136     (call-with-blocked-asyncs
 137      (lambda () (loop (lambda () #t))))))
 138
 139 (define (error-catching-repl r e p)
 140   (error-catching-loop
 141    (lambda ()
 142      (call-with-values (lambda () (e (r)))
 143        (lambda the-values (for-each p the-values))))))
 144
 145 (define (scm-style-repl)
 146   (letrec (
 147            (start-gc-rt #f)
 148            (start-rt #f)
 149            (repl-report-start-timing (lambda ()
 150                                        (set! start-gc-rt (gc-run-time))
 151                                        (set! start-rt (get-internal-run-time))))
 152            (repl-report (lambda ()
 153                           (display ";;; ")
 154                           (display (inexact->exact
 155                                     (* 1000 (/ (- (get-internal-run-time) start-rt)
 156                                                internal-time-units-per-second))))
 157                           (display "  msec  (")
 158                           (display  (inexact->exact
 159                                      (* 1000 (/ (- (gc-run-time) start-gc-rt)
 160                                                 internal-time-units-per-second))))
 161                           (display " msec in gc)\n")))
 162
 163            (consume-trailing-whitespace
 164             (lambda ()
 165               (let ((ch (peek-char)))
 166                 (cond
 167                  ((eof-object? ch))
 168                  ((or (char=? ch #\space) (char=? ch #\tab))
 169                   (read-char)
 170                   (consume-trailing-whitespace))
 171                  ((char=? ch #\newline)
 172                   (read-char))))))
 173            (-read (lambda ()
 174                     (let ((val
 175                            (let ((prompt (cond ((string? scm-repl-prompt)
 176                                                 scm-repl-prompt)
 177                                                ((thunk? scm-repl-prompt)
 178                                                 (scm-repl-prompt))
 179                                                (scm-repl-prompt "> ")
 180                                                (else ""))))
 181                              (repl-reader prompt))))
 182
 183                       ;; As described in R4RS, the READ procedure updates the
 184                       ;; port to point to the first character past the end of
 185                       ;; the external representation of the object.  This
 186                       ;; means that it doesn't consume the newline typically
 187                       ;; found after an expression.  This means that, when
 188                       ;; debugging Guile with GDB, GDB gets the newline, which
 189                       ;; it often interprets as a "continue" command, making
 190                       ;; breakpoints kind of useless.  So, consume any
 191                       ;; trailing newline here, as well as any whitespace
 192                       ;; before it.
 193                       ;; But not if EOF, for control-D.
 194                       (if (not (eof-object? val))
 195                           (consume-trailing-whitespace))
 196                       (run-hook after-read-hook)
 197                       (if (eof-object? val)
 198                           (begin
 199                             (repl-report-start-timing)
 200                             (if scm-repl-verbose
 201                                 (begin
 202                                   (newline)
 203                                   (display ";;; EOF -- quitting")
 204                                   (newline)))
 205                             (quit 0)))
 206                       val)))
 207
 208            (-eval (lambda (sourc)
 209                     (repl-report-start-timing)
 210                     (run-hook before-eval-hook sourc)
 211                     (let ((val (start-stack 'repl-stack
 212                                             ;; If you change this procedure
 213                                             ;; (primitive-eval), please also
 214                                             ;; modify the repl-stack case in
 215                                             ;; save-stack so that stack cutting
 216                                             ;; continues to work.
 217                                             (primitive-eval sourc))))
 218                       (run-hook after-eval-hook sourc)
 219                       val)))
 220
 221
 222            (-print (let ((maybe-print (lambda (result)
 223                                         (if (or scm-repl-print-unspecified
 224                                                 (not (unspecified? result)))
 225                                             (begin
 226                                               (write result)
 227                                               (newline))))))
 228                      (lambda (result)
 229                        (if (not scm-repl-silent)
 230                            (begin
 231                              (run-hook before-print-hook result)
 232                              (maybe-print result)
 233                              (run-hook after-print-hook result)
 234                              (if scm-repl-verbose
 235                                  (repl-report))
 236                              (force-output))))))
 237
 238            (-quit (lambda (args)
 239                     (if scm-repl-verbose
 240                         (begin
 241                           (display ";;; QUIT executed, repl exitting")
 242                           (newline)
 243                           (repl-report)))
 244                     args)))
 245
 246     (let ((status (error-catching-repl -read
 247                                        -eval
 248                                        -print)))
 249       (-quit status))))