module/system/repl/error-handling.scm

   1 ;;; Error handling in the REPL
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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 error-handling)
  23   #:use-module (system base pmatch)
  24   #:use-module (system vm trap-state)
  25   #:use-module (system repl debug)
  26   #:use-module (ice-9 format)
  27   #:export (call-with-error-handling
  28             with-error-handling))
  29
  30
  31 \f
  32
  33 ;;;
  34 ;;; Error handling via repl debugging
  35 ;;;
  36
  37 (define (error-string stack key args)
  38   (call-with-output-string
  39    (lambda (port)
  40      (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
  41        (print-exception port frame key args)))))
  42
  43 (define* (call-with-error-handling thunk #:key
  44                                    (on-error 'debug) (post-error 'catch)
  45                                    (pass-keys '(quit)) (trap-handler 'debug)
  46                                    (report-keys '(stack-overflow out-of-memory)))
  47   (let ((in (current-input-port))
  48         (out (current-output-port))
  49         (err (current-error-port)))
  50     (define (with-saved-ports thunk)
  51       (with-input-from-port in
  52         (lambda ()
  53           (with-output-to-port out
  54             (lambda ()
  55               (with-error-to-port err
  56                 thunk))))))
  57
  58     (define (debug-trap-handler frame trap-idx trap-name)
  59       (let* ((tag (and (pair? (fluid-ref %stacks))
  60                        (cdar (fluid-ref %stacks))))
  61              (stack (narrow-stack->vector
  62                      (make-stack frame)
  63                      ;; Take the stack from the given frame, cutting 0
  64                      ;; frames.
  65                      0
  66                      ;; Narrow the end of the stack to the most recent
  67                      ;; start-stack.
  68                      tag
  69                      ;; And one more frame, because %start-stack
  70                      ;; invoking the start-stack thunk has its own frame
  71                      ;; too.
  72                      0 (and tag 1)))
  73              (error-msg (if trap-idx
  74                             (format #f "Trap ~d: ~a" trap-idx trap-name)
  75                             trap-name))
  76              (debug (make-debug stack 0 error-msg)))
  77         (with-saved-ports
  78          (lambda ()
  79            (if trap-idx
  80                (begin
  81                  (format #t "~a~%" error-msg)
  82                  (format #t "Entering a new prompt.  ")
  83                  (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")))
  84            ((@ (system repl repl) start-repl) #:debug debug)))))
  85
  86     (define (null-trap-handler frame trap-idx trap-name)
  87       #t)
  88
  89     (define le-trap-handler
  90       (case trap-handler
  91         ((debug) debug-trap-handler)
  92         ((pass) null-trap-handler)
  93         ((disabled) #f)
  94         (else (error "Unknown trap-handler strategy" trap-handler))))
  95
  96     (define (report-error key args)
  97       (with-saved-ports
  98        (lambda ()
  99          (run-hook before-error-hook)
 100          (print-exception err #f key args)
 101          (run-hook after-error-hook)
 102          (force-output err))))
 103
 104     (catch #t
 105       (lambda ()
 106         (with-default-trap-handler le-trap-handler
 107           (lambda () (%start-stack #t thunk))))
 108
 109       (case post-error
 110         ((report)
 111          (lambda (key . args)
 112            (if (memq key pass-keys)
 113                (apply throw key args)
 114                (begin
 115                  (report-error key args)
 116                  (if #f #f)))))
 117         ((catch)
 118          (lambda (key . args)
 119            (when (memq key pass-keys)
 120              (apply throw key args))
 121            (when (memq key report-keys)
 122              (report-error key args))
 123            (if #f #f)))
 124         (else
 125          (if (procedure? post-error)
 126              (lambda (k . args)
 127                (apply (if (memq k pass-keys) throw post-error) k args))
 128              (error "Unknown post-error strategy" post-error))))
 129
 130       (case on-error
 131         ((debug)
 132          (lambda (key . args)
 133            (if (not (memq key pass-keys))
 134                (let* ((tag (and (pair? (fluid-ref %stacks))
 135                                 (cdar (fluid-ref %stacks))))
 136                       (stack (narrow-stack->vector
 137                               (make-stack #t)
 138                               ;; Cut three frames from the top of the stack:
 139                               ;; make-stack, this one, and the throw handler.
 140                               3
 141                               ;; Narrow the end of the stack to the most recent
 142                               ;; start-stack.
 143                               tag
 144                               ;; And one more frame, because %start-stack invoking
 145                               ;; the start-stack thunk has its own frame too.
 146                               0 (and tag 1)))
 147                       (error-msg (error-string stack key args))
 148                       (debug (make-debug stack 0 error-msg)))
 149                  (with-saved-ports
 150                   (lambda ()
 151                     (format #t "~a~%" error-msg)
 152                     (format #t "Entering a new prompt.  ")
 153                     (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
 154                     ((@ (system repl repl) start-repl) #:debug debug)))))))
 155         ((report)
 156          (lambda (key . args)
 157            (unless (memq key pass-keys)
 158              (report-error key args))
 159            (if #f #f)))
 160         ((backtrace)
 161          (lambda (key . args)
 162            (if (not (memq key pass-keys))
 163                (let* ((tag (and (pair? (fluid-ref %stacks))
 164                                 (cdar (fluid-ref %stacks))))
 165                       (frames (narrow-stack->vector
 166                                (make-stack #t)
 167                                ;; Narrow as above, for the debugging case.
 168                                3 tag 0 (and tag 1))))
 169                  (with-saved-ports (lambda () (print-frames frames)))
 170                  (report-error key args)
 171                  (if #f #f)))))
 172         ((pass)
 173          (lambda (key . args)
 174            ;; fall through to rethrow
 175            #t))
 176         (else
 177          (if (procedure? on-error)
 178              (lambda (k . args)
 179                (apply (if (memq k pass-keys) throw on-error) k args))
 180              (error "Unknown on-error strategy" on-error)))))))
 181
 182 (define-syntax-rule (with-error-handling form)
 183   (call-with-error-handling (lambda () form)))