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 (if trap-idx
  76                             (format #f "Trap ~d: ~a" trap-idx trap-name)
  77                             trap-name))
  78              (debug (make-debug stack 0 error-msg)))
  79         (with-saved-ports
  80          (lambda ()
  81            (if trap-idx
  82                (begin
  83                  (format #t "~a~%" error-msg)
  84                  (format #t "Entering a new prompt.  ")
  85                  (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")))
  86            ((@ (system repl repl) start-repl) #:debug debug)))))
  87
  88     (define (null-trap-handler frame trap-idx trap-name)
  89       #t)
  90
  91     (define le-trap-handler
  92       (case trap-handler
  93         ((debug) debug-trap-handler)
  94         ((pass) null-trap-handler)
  95         ((disabled) #f)
  96         (else (error "Unknown trap-handler strategy" trap-handler))))
  97
  98     (catch #t
  99       (lambda ()
 100         (with-default-trap-handler le-trap-handler
 101           (lambda () (%start-stack #t thunk))))
 102
 103       (case post-error
 104         ((report)
 105          (lambda (key . args)
 106            (if (memq key pass-keys)
 107                (apply throw key args)
 108                (begin
 109                  (pmatch args
 110                    ((,subr ,msg ,args . ,rest)
 111                     (with-saved-ports
 112                      (lambda ()
 113                        (run-hook before-error-hook)
 114                        (display-error #f err subr msg args rest)
 115                        (run-hook after-error-hook)
 116                        (force-output err))))
 117                    (else
 118                     (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
 119                             key args)))
 120                  (if #f #f)))))
 121         ((catch)
 122          (lambda (key . args)
 123            (if (memq key pass-keys)
 124                (apply throw key args))))
 125         (else
 126          (if (procedure? post-error)
 127              post-error                 ; a handler proc
 128              (error "Unknown post-error strategy" post-error))))
 129
 130       (case on-error
 131         ((debug)
 132          (lambda (key . args)
 133            (let* ((tag (and (pair? (fluid-ref %stacks))
 134                             (cdar (fluid-ref %stacks))))
 135                   (stack (narrow-stack->vector
 136                           (make-stack #t)
 137                           ;; Cut three frames from the top of the stack:
 138                           ;; make-stack, this one, and the throw handler.
 139                           3
 140                           ;; Narrow the end of the stack to the most recent
 141                           ;; start-stack.
 142                           tag
 143                           ;; And one more frame, because %start-stack invoking
 144                           ;; the start-stack thunk has its own frame too.
 145                           0 (and tag 1)))
 146                   (error-msg (error-string stack key args))
 147                   (debug (make-debug stack 0 error-msg)))
 148              (with-saved-ports
 149               (lambda ()
 150                 (format #t error-msg)
 151                 (format #t "Entering a new prompt.  ")
 152                 (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
 153                 ((@ (system repl repl) start-repl) #:debug debug))))))
 154         ((pass)
 155          (lambda (key . args)
 156            ;; fall through to rethrow
 157            #t))
 158         (else
 159          (if (procedure? on-error)
 160              on-error                   ; pre-unwind handler
 161              (error "Unknown on-error strategy" on-error)))))))
 162
 163 (define-syntax with-error-handling
 164   (syntax-rules ()
 165     ((_ form)
 166      (call-with-error-handling (lambda () form)))))