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   #:use-module (ice-9 save-stack)
  21
  22   #:export (scm-repl-silent
  23             scm-repl-print-unspecified
  24             scm-repl-verbose
  25             scm-repl-prompt)
  26
  27   ;; #:replace, as with deprecated code enabled these will be in the root env
  28   #:replace (assert-repl-silence
  29              assert-repl-print-unspecified
  30              assert-repl-verbosity
  31
  32              default-pre-unwind-handler
  33              bad-throw
  34              error-catching-loop
  35              error-catching-repl
  36              scm-style-repl
  37              handle-system-error))
  38
  39 (define scm-repl-silent #f)
  40 (define (assert-repl-silence v) (set! scm-repl-silent v))
  41
  42 (define scm-repl-print-unspecified #f)
  43 (define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
  44
  45 (define scm-repl-verbose #f)
  46 (define (assert-repl-verbosity v) (set! scm-repl-verbose v))
  47
  48 (define scm-repl-prompt "guile> ")
  49
  50 \f
  51
  52 ;; bad-throw is the hook that is called upon a throw to a an unhandled
  53 ;; key (unless the throw has four arguments, in which case
  54 ;; it's usually interpreted as an error throw.)
  55 ;; If the key has a default handler (a throw-handler-default property),
  56 ;; it is applied to the throw.
  57 ;;
  58 (define (bad-throw key . args)
  59   (let ((default (symbol-property key 'throw-handler-default)))
  60     (or (and default (apply default key args))
  61         (apply error "unhandled-exception:" key args))))
  62
  63 \f
  64
  65 (define (default-pre-unwind-handler key . args)
  66   ;; Narrow by two more frames: this one, and the throw handler.
  67   (save-stack 2)
  68   (apply throw key args))
  69
  70 \f
  71
  72 (define has-shown-debugger-hint? #f)
  73
  74 (define (error-catching-loop thunk)
  75   (let ((status #f)
  76         (interactive #t))
  77     (define (loop first)
  78       (let ((next
  79              (catch #t
  80
  81                     (lambda ()
  82                       (call-with-unblocked-asyncs
  83                        (lambda ()
  84                          (with-traps
  85                           (lambda ()
  86                             (first)
  87
  88                             ;; This line is needed because mark
  89                             ;; doesn't do closures quite right.
  90                             ;; Unreferenced locals should be
  91                             ;; collected.
  92                             (set! first #f)
  93                             (let loop ((v (thunk)))
  94                               (loop (thunk)))
  95                             #f)))))
  96
  97                     (lambda (key . args)
  98                       (case key
  99                         ((quit)
 100                          (set! status args)
 101                          #f)
 102
 103                         ((switch-repl)
 104                          (apply throw 'switch-repl args))
 105
 106                         ((abort)
 107                          ;; This is one of the closures that require
 108                          ;; (set! first #f) above
 109                          ;;
 110                          (lambda ()
 111                            (run-hook abort-hook)
 112                            (force-output (current-output-port))
 113                            (display "ABORT: "  (current-error-port))
 114                            (write args (current-error-port))
 115                            (newline (current-error-port))
 116                            (if interactive
 117                                (begin
 118                                  (if (and
 119                                       (not has-shown-debugger-hint?)
 120                                       (not (memq 'backtrace
 121                                                  (debug-options-interface)))
 122                                       (stack? (fluid-ref the-last-stack)))
 123                                      (begin
 124                                        (newline (current-error-port))
 125                                        (display
 126                                         "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
 127                                         (current-error-port))
 128                                        (set! has-shown-debugger-hint? #t)))
 129                                  (force-output (current-error-port)))
 130                                (begin
 131                                  (primitive-exit 1)))
 132                            (set! stack-saved? #f)))
 133
 134                         (else
 135                          ;; This is the other cons-leak closure...
 136                          (lambda ()
 137                            (cond ((= (length args) 4)
 138                                   (apply handle-system-error key args))
 139                                  (else
 140                                   (apply bad-throw key args)))))))
 141
 142                     default-pre-unwind-handler)))
 143
 144         (if next (loop next) status)))
 145     (set! ensure-batch-mode! (lambda ()
 146                                (set! interactive #f)
 147                                (restore-signals)))
 148     (set! batch-mode? (lambda () (not interactive)))
 149     (call-with-blocked-asyncs
 150      (lambda () (loop (lambda () #t))))))
 151
 152 (define (error-catching-repl r e p)
 153   (error-catching-loop
 154    (lambda ()
 155      (call-with-values (lambda () (e (r)))
 156        (lambda the-values (for-each p the-values))))))
 157
 158 (define (scm-style-repl)
 159   (letrec (
 160            (start-gc-rt #f)
 161            (start-rt #f)
 162            (repl-report-start-timing (lambda ()
 163                                        (set! start-gc-rt (gc-run-time))
 164                                        (set! start-rt (get-internal-run-time))))
 165            (repl-report (lambda ()
 166                           (display ";;; ")
 167                           (display (inexact->exact
 168                                     (* 1000 (/ (- (get-internal-run-time) start-rt)
 169                                                internal-time-units-per-second))))
 170                           (display "  msec  (")
 171                           (display  (inexact->exact
 172                                      (* 1000 (/ (- (gc-run-time) start-gc-rt)
 173                                                 internal-time-units-per-second))))
 174                           (display " msec in gc)\n")))
 175
 176            (consume-trailing-whitespace
 177             (lambda ()
 178               (let ((ch (peek-char)))
 179                 (cond
 180                  ((eof-object? ch))
 181                  ((or (char=? ch #\space) (char=? ch #\tab))
 182                   (read-char)
 183                   (consume-trailing-whitespace))
 184                  ((char=? ch #\newline)
 185                   (read-char))))))
 186            (-read (lambda ()
 187                     (let ((val
 188                            (let ((prompt (cond ((string? scm-repl-prompt)
 189                                                 scm-repl-prompt)
 190                                                ((thunk? scm-repl-prompt)
 191                                                 (scm-repl-prompt))
 192                                                (scm-repl-prompt "> ")
 193                                                (else ""))))
 194                              (repl-reader prompt))))
 195
 196                       ;; As described in R4RS, the READ procedure updates the
 197                       ;; port to point to the first character past the end of
 198                       ;; the external representation of the object.  This
 199                       ;; means that it doesn't consume the newline typically
 200                       ;; found after an expression.  This means that, when
 201                       ;; debugging Guile with GDB, GDB gets the newline, which
 202                       ;; it often interprets as a "continue" command, making
 203                       ;; breakpoints kind of useless.  So, consume any
 204                       ;; trailing newline here, as well as any whitespace
 205                       ;; before it.
 206                       ;; But not if EOF, for control-D.
 207                       (if (not (eof-object? val))
 208                           (consume-trailing-whitespace))
 209                       (run-hook after-read-hook)
 210                       (if (eof-object? val)
 211                           (begin
 212                             (repl-report-start-timing)
 213                             (if scm-repl-verbose
 214                                 (begin
 215                                   (newline)
 216                                   (display ";;; EOF -- quitting")
 217                                   (newline)))
 218                             (quit 0)))
 219                       val)))
 220
 221            (-eval (lambda (sourc)
 222                     (repl-report-start-timing)
 223                     (run-hook before-eval-hook sourc)
 224                     (let ((val (start-stack 'repl-stack
 225                                             ;; If you change this procedure
 226                                             ;; (primitive-eval), please also
 227                                             ;; modify the repl-stack case in
 228                                             ;; save-stack so that stack cutting
 229                                             ;; continues to work.
 230                                             (primitive-eval sourc))))
 231                       (run-hook after-eval-hook sourc)
 232                       val)))
 233
 234
 235            (-print (let ((maybe-print (lambda (result)
 236                                         (if (or scm-repl-print-unspecified
 237                                                 (not (unspecified? result)))
 238                                             (begin
 239                                               (write result)
 240                                               (newline))))))
 241                      (lambda (result)
 242                        (if (not scm-repl-silent)
 243                            (begin
 244                              (run-hook before-print-hook result)
 245                              (maybe-print result)
 246                              (run-hook after-print-hook result)
 247                              (if scm-repl-verbose
 248                                  (repl-report))
 249                              (force-output))))))
 250
 251            (-quit (lambda (args)
 252                     (if scm-repl-verbose
 253                         (begin
 254                           (display ";;; QUIT executed, repl exitting")
 255                           (newline)
 256                           (repl-report)))
 257                     args)))
 258
 259     (let ((status (error-catching-repl -read
 260                                        -eval
 261                                        -print)))
 262       (-quit status))))
 263
 264 (define (handle-system-error key . args)
 265   (let ((cep (current-error-port)))
 266     (cond ((not (stack? (fluid-ref the-last-stack))))
 267           ((memq 'backtrace (debug-options-interface))
 268            (let ((highlights (if (or (eq? key 'wrong-type-arg)
 269                                      (eq? key 'out-of-range))
 270                                  (list-ref args 3)
 271                                  '())))
 272              (run-hook before-backtrace-hook)
 273              (newline cep)
 274              (display "Backtrace:\n")
 275              (display-backtrace (fluid-ref the-last-stack) cep
 276                                 #f #f highlights)
 277              (newline cep)
 278              (run-hook after-backtrace-hook))))
 279     (run-hook before-error-hook)
 280     (apply display-error (fluid-ref the-last-stack) cep args)
 281     (run-hook after-error-hook)
 282     (force-output cep)
 283     (throw 'abort key)))