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 repl debug)
  25   #:export (call-with-error-handling
  26             with-error-handling))
  27
  28
  29 \f
  30
  31 ;;;
  32 ;;; Error handling via repl debugging
  33 ;;;
  34
  35 (define* (call-with-error-handling thunk #:key
  36                                    (on-error 'debug) (post-error 'catch)
  37                                    (pass-keys '(quit)))
  38   (let ((in (current-input-port))
  39         (out (current-output-port))
  40         (err (current-error-port)))
  41     (define (with-saved-ports thunk)
  42       (with-input-from-port in
  43         (lambda ()
  44           (with-output-to-port out
  45             (lambda ()
  46               (with-error-to-port err
  47                 thunk))))))
  48
  49     (catch #t
  50       (lambda () (%start-stack #t thunk))
  51
  52       (case post-error
  53         ((catch)
  54          (lambda (key . args)
  55            (if (memq key pass-keys)
  56                (apply throw key args)
  57                (begin
  58                  (pmatch args
  59                   ((,subr ,msg ,args . ,rest)
  60                    (with-saved-ports
  61                     (lambda ()
  62                       (run-hook before-error-hook)
  63                       (display-error #f err subr msg args rest)
  64                       (run-hook after-error-hook)
  65                       (force-output err))))
  66                   (else
  67                    (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
  68                            key args)))
  69                  (if #f #f)))))
  70         (else
  71          (if (procedure? post-error)
  72              post-error ; a handler proc
  73              (error "Unknown post-error strategy" post-error))))
  74
  75       (case on-error
  76         ((debug)
  77          (lambda (key . args)
  78            (let ((stack (make-stack #t)))
  79              (with-saved-ports
  80               (lambda ()
  81                 (pmatch args
  82                   ((,subr ,msg ,args . ,rest)
  83                    (format #t "Throw to key `~a':\n" key)
  84                    (display-error stack (current-output-port) subr msg args rest))
  85                   (else
  86                    (format #t "Throw to key `~a' with args `~s'." key args)))
  87                 (format #t "Entering a new prompt. Type `,bt' for a backtrace")
  88                 (format #t " or `,q' to return to the old prompt.\n")
  89                 (let ((debug
  90                        (make-debug
  91                         (let ((tag (and (pair? (fluid-ref %stacks))
  92                                         (cdar (fluid-ref %stacks)))))
  93                           (narrow-stack->vector
  94                            stack
  95                            ;; Cut three frames from the top of the stack:
  96                            ;; make-stack, this one, and the throw handler.
  97                            3
  98                            ;; Narrow the end of the stack to the most recent
  99                            ;; start-stack.
 100                            tag
 101                            ;; And one more frame, because %start-stack invoking
 102                            ;; the start-stack thunk has its own frame too.
 103                            0 (and tag 1)))
 104                         0)))
 105                   ((@ (system repl repl) start-repl) #:debug debug)))))))
 106         ((pass)
 107          (lambda (key . args)
 108            ;; fall through to rethrow
 109            #t))
 110         (else
 111          (if (procedure? on-error)
 112              on-error ; pre-unwind handler
 113              (error "Unknown on-error strategy" on-error)))))))
 114
 115 (define-syntax with-error-handling
 116   (syntax-rules ()
 117     ((_ form)
 118      (call-with-error-handling (lambda () form)))))