mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Reimplement catch, throw, and with-throw-handler

Browse source 
* module/ice-9/boot-9.scm: Reimplement catch, throw, and
  with-throw-handler in such a way that the exception handler is
  threaded not through the exception-handling closures, but through a
  data structure in the exception-handler fluid.  This will allow us to
  do unwind-only exception dispatch on stack overflow.
This commit is contained in:
Andy Wingo 2014-02-19 19:43:48 +01:00
parent 440392fa2d
commit 0f0b6f2d86
1 changed files with 80 additions and 73 deletions
Download patch file Download diff file Expand all files Collapse all files

153
module/ice-9/boot-9.scm
View file

@ -707,46 +707,65 @@ information is unavailable."
(define with-throw-handler #f) (define with-throw-handler #f)
(let () (let ()
(define (default-exception-handler k . args) (define %exception-handler (make-fluid #f))
(cond (define (make-exception-handler catch-key prompt-tag pre-unwind)
((eq? k 'quit) (vector (fluid-ref %exception-handler) catch-key prompt-tag pre-unwind))
(primitive-exit (cond (define (exception-handler-prev handler) (vector-ref handler 0))
((not (pair? args)) 0) (define (exception-handler-catch-key handler) (vector-ref handler 1))
((integer? (car args)) (car args)) (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
((not (car args)) 1) (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
(else 0))))
(else
(format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
(primitive-exit 1))))
(define %running-exception-handlers (make-fluid '())) (define %running-pre-unwind (make-fluid '()))
(define %exception-handler (make-fluid default-exception-handler))
(define (default-throw-handler prompt-tag catch-k) (define (dispatch-exception handler key args)
(let ((prev (fluid-ref %exception-handler))) (unless handler
(lambda (thrown-k . args) (when (eq? key 'quit)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t)) (primitive-exit (cond
(apply abort-to-prompt prompt-tag thrown-k args) ((not (pair? args)) 0)
(apply prev thrown-k args))))) ((integer? (car args)) (car args))
((not (car args)) 1)
(else 0))))
(format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
(primitive-exit 1))
(define (custom-throw-handler prompt-tag catch-k pre) (let ((catch-key (exception-handler-catch-key handler))
(let ((prev (fluid-ref %exception-handler))) (prev (exception-handler-prev handler)))
(lambda (thrown-k . args) (if (or (eqv? catch-key #t) (eq? catch-key key))
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t)) (let ((prompt-tag (exception-handler-prompt-tag handler))
(let ((running (fluid-ref %running-exception-handlers))) (pre-unwind (exception-handler-pre-unwind handler)))
(with-fluid* %running-exception-handlers (cons pre running) (if pre-unwind
(lambda () ;; Instead of using a "running" set, it would be a lot
(if (not (memq pre running)) ;; cleaner semantically to roll back the exception
(apply pre thrown-k args)) ;; handler binding to the one that was in place when the
;; fall through ;; pre-unwind handler was installed, and keep it like
(if prompt-tag ;; that for the rest of the dispatch. Unfortunately
(apply abort-to-prompt prompt-tag thrown-k args) ;; that is incompatible with existing semantics. We'll
(apply prev thrown-k args))))) ;; see if we can change that later on.
(apply prev thrown-k args))))) (let ((running (fluid-ref %running-pre-unwind)))
(with-fluid* %running-pre-unwind (cons handler running)
(lambda ()
(unless (memq handler running)
(apply pre-unwind key args))
(if prompt-tag
(apply abort-to-prompt prompt-tag key args)
(dispatch-exception prev key args)))))
(apply abort-to-prompt prompt-tag key args)))
(dispatch-exception prev key args))))
(set! catch (define (throw key . args)
(lambda* (k thunk handler #:optional pre-unwind-handler) "Invoke the catch form matching @var{key}, passing @var{args} to the
"Invoke @var{thunk} in the dynamic context of @var{handler} for @var{handler}.
@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
If there is no handler at all, Guile prints an error and then exits."
(unless (symbol? key)
(throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
(list 1 key) (list key)))
(dispatch-exception (fluid-ref %exception-handler) key args))
(define* (catch k thunk handler #:optional pre-unwind-handler)
"Invoke @var{thunk} in the dynamic context of @var{handler} for
exceptions matching @var{key}. If thunk throws to the symbol exceptions matching @var{key}. If thunk throws to the symbol
@var{key}, then @var{handler} is invoked this way: @var{key}, then @var{handler} is invoked this way:
@lisp @lisp
@ -779,46 +798,34 @@ A @var{pre-unwind-handler} can exit either normally or non-locally.
If it exits normally, Guile unwinds the stack and dynamic context If it exits normally, Guile unwinds the stack and dynamic context
and then calls the normal (third argument) handler. If it exits and then calls the normal (third argument) handler. If it exits
non-locally, that exit determines the continuation." non-locally, that exit determines the continuation."
(if (not (or (symbol? k) (eqv? k #t))) (if (not (or (symbol? k) (eqv? k #t)))
(scm-error 'wrong-type-arg "catch" (scm-error 'wrong-type-arg "catch"
"Wrong type argument in position ~a: ~a" "Wrong type argument in position ~a: ~a"
(list 1 k) (list k))) (list 1 k) (list k)))
(let ((tag (make-prompt-tag "catch"))) (let ((tag (make-prompt-tag "catch")))
(call-with-prompt (call-with-prompt
tag tag
(lambda () (lambda ()
(with-fluid* %exception-handler (with-fluid* %exception-handler
(if pre-unwind-handler (make-exception-handler k tag pre-unwind-handler)
(custom-throw-handler tag k pre-unwind-handler) thunk))
(default-throw-handler tag k)) (lambda (cont k . args)
thunk)) (apply handler k args)))))
(lambda (cont k . args)
(apply handler k args))))))
(set! with-throw-handler (define (with-throw-handler k thunk pre-unwind-handler)
(lambda (k thunk pre-unwind-handler) "Add @var{handler} to the dynamic context as a throw handler
"Add @var{handler} to the dynamic context as a throw handler
for key @var{k}, then invoke @var{thunk}." for key @var{k}, then invoke @var{thunk}."
(if (not (or (symbol? k) (eqv? k #t))) (if (not (or (symbol? k) (eqv? k #t)))
(scm-error 'wrong-type-arg "with-throw-handler" (scm-error 'wrong-type-arg "with-throw-handler"
"Wrong type argument in position ~a: ~a" "Wrong type argument in position ~a: ~a"
(list 1 k) (list k))) (list 1 k) (list k)))
(with-fluid* %exception-handler (with-fluid* %exception-handler
(custom-throw-handler #f k pre-unwind-handler) (make-exception-handler k #f pre-unwind-handler)
thunk))) thunk))
(set! throw (define! 'catch catch)
(lambda (key . args) (define! 'with-throw-handler with-throw-handler)
"Invoke the catch form matching @var{key}, passing @var{args} to the (define! 'throw throw))
@var{handler}.
@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
If there is no handler at all, Guile prints an error and then exits."
(if (not (symbol? key))
((fluid-ref %exception-handler) 'wrong-type-arg "throw"
"Wrong type argument in position ~a: ~a" (list 1 key) (list key))
(apply (fluid-ref %exception-handler) key args)))))