module/system/repl/error-handling.scm

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