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