;;; Error handling in the REPL
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
(define-module (system repl error-handling)
#:use-module (system base pmatch)
+ #:use-module (system vm trap-state)
#:use-module (system repl debug)
+ #:use-module (ice-9 format)
#:export (call-with-error-handling
with-error-handling))
;;; Error handling via repl debugging
;;;
+(define (error-string stack key args)
+ (call-with-output-string
+ (lambda (port)
+ (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
+ (print-exception port frame key args)))))
+
(define* (call-with-error-handling thunk #:key
(on-error 'debug) (post-error 'catch)
- (pass-keys '(quit)))
+ (pass-keys '(quit)) (trap-handler 'debug))
(let ((in (current-input-port))
(out (current-output-port))
(err (current-error-port)))
(lambda ()
(with-error-to-port err
thunk))))))
-
+
+ (define (debug-trap-handler frame trap-idx trap-name)
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (stack (narrow-stack->vector
+ (make-stack frame)
+ ;; Take the stack from the given frame, cutting 0
+ ;; frames.
+ 0
+ ;; Narrow the end of the stack to the most recent
+ ;; start-stack.
+ tag
+ ;; And one more frame, because %start-stack
+ ;; invoking the start-stack thunk has its own frame
+ ;; too.
+ 0 (and tag 1)))
+ (error-msg (if trap-idx
+ (format #f "Trap ~d: ~a" trap-idx trap-name)
+ trap-name))
+ (debug (make-debug stack 0 error-msg #t)))
+ (with-saved-ports
+ (lambda ()
+ (if trap-idx
+ (begin
+ (format #t "~a~%" error-msg)
+ (format #t "Entering a new prompt. ")
+ (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")))
+ ((@ (system repl repl) start-repl) #:debug debug)))))
+
+ (define (null-trap-handler frame trap-idx trap-name)
+ #t)
+
+ (define le-trap-handler
+ (case trap-handler
+ ((debug) debug-trap-handler)
+ ((pass) null-trap-handler)
+ ((disabled) #f)
+ (else (error "Unknown trap-handler strategy" trap-handler))))
+
(catch #t
- (lambda () (%start-stack #t thunk))
+ (lambda ()
+ (with-default-trap-handler le-trap-handler
+ (lambda () (%start-stack #t thunk))))
(case post-error
((report)
(if (memq key pass-keys)
(apply throw key args)
(begin
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (with-saved-ports
- (lambda ()
- (run-hook before-error-hook)
- (display-error #f err subr msg args rest)
- (run-hook after-error-hook)
- (force-output err))))
- (else
- (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
- key args)))
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
(if #f #f)))))
((catch)
(lambda (key . args)
(apply throw key args))))
(else
(if (procedure? post-error)
- post-error ; a handler proc
+ (lambda (k . args)
+ (apply (if (memq k pass-keys) throw post-error) k args))
(error "Unknown post-error strategy" post-error))))
-
+
(case on-error
((debug)
(lambda (key . args)
- (let* ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks))))
- (stack (narrow-stack->vector
- (make-stack #t)
- ;; Cut three frames from the top of the stack:
- ;; make-stack, this one, and the throw handler.
- 3
- ;; Narrow the end of the stack to the most recent
- ;; start-stack.
- tag
- ;; And one more frame, because %start-stack invoking
- ;; the start-stack thunk has its own frame too.
- 0 (and tag 1)))
- (debug (make-debug stack 0)))
- (with-saved-ports
- (lambda ()
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (display-error (vector-ref stack 0) (current-output-port)
- subr msg args rest))
- (else
- (format #t "Throw to key `~a' with args `~s'." key args)))
- (format #t "Entering a new prompt. ")
- (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
- ((@ (system repl repl) start-repl) #:debug debug))))))
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (stack (narrow-stack->vector
+ (make-stack #t)
+ ;; Cut three frames from the top of the stack:
+ ;; make-stack, this one, and the throw handler.
+ 3
+ ;; Narrow the end of the stack to the most recent
+ ;; start-stack.
+ tag
+ ;; And one more frame, because %start-stack invoking
+ ;; the start-stack thunk has its own frame too.
+ 0 (and tag 1)))
+ (error-msg (error-string stack key args))
+ (debug (make-debug stack 0 error-msg #f)))
+ (with-saved-ports
+ (lambda ()
+ (format #t "~a~%" error-msg)
+ (format #t "Entering a new prompt. ")
+ (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+ ((@ (system repl repl) start-repl) #:debug debug)))))))
+ ((report)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (begin
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
+ ((backtrace)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (frames (narrow-stack->vector
+ (make-stack #t)
+ ;; Narrow as above, for the debugging case.
+ 3 tag 0 (and tag 1))))
+ (with-saved-ports
+ (lambda ()
+ (print-frames frames)
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
((pass)
(lambda (key . args)
;; fall through to rethrow
#t))
(else
(if (procedure? on-error)
- on-error ; pre-unwind handler
+ (lambda (k . args)
+ (apply (if (memq k pass-keys) throw on-error) k args))
(error "Unknown on-error strategy" on-error)))))))
-(define-syntax with-error-handling
- (syntax-rules ()
- ((_ form)
- (call-with-error-handling (lambda () form)))))
+(define-syntax-rule (with-error-handling form)
+ (call-with-error-handling (lambda () form)))
HCoop / bpt / guile.git / blobdiff