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

Convert guile exceptions to R6RS conditions in R6RS exception handlers.

Browse source 
* module/rnrs/exceptions.scm (&guile): New condition type.

  (guile-condition-converters): New variable.

  (convert-guile-condition, default-guile-condition-converter,
  set-guile-condition-converter!, guile-common-conditions,
  guile-lexical-violation-converter, guile-syntax-violation-converter,
  guile-assertion-violation-converter, guile-system-error-converter,
  guile-undefined-violation-converter, guile-error-converter,
  guile-implementation-restriction-converter): New procedures.

  (with-exception-handler): Catch all exceptions, not just R6RS
  exceptions.  Convert native Guile exceptions to R6RS conditions,
  preserving the original Guile exception information in the &guile
  condition object.

  (raise): If the condition includes a &guile condition, use 'throw' to
  throw the original native guile exception instead of raising an R6RS
  exception.

* test-suite/tests/r6rs-exceptions.test ("guile condition conversions"):
  Add tests.
This commit is contained in:
Mark H Weaver 2013-08-09 18:27:20 -04:00
parent 750ac8c592
commit 02500d4477
2 changed files with 205 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

62
test-suite/tests/r6rs-exceptions.test
View file

@ -1,6 +1,6 @@
;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)
;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions) -*- scheme -*-
;; Copyright (C) 2010 Free Software Foundation, Inc.
;; Copyright (C) 2010, 2013 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
@ -20,6 +20,7 @@
(define-module (test-suite test-rnrs-exceptions)
:use-module ((rnrs conditions) :version (6))
:use-module ((rnrs exceptions) :version (6))
:use-module (system foreign)
:use-module (test-suite lib))
(with-test-prefix "with-exception-handler"
@ -96,3 +97,60 @@
(pass-if "guard with cond => syntax"
(guard (condition (condition => error?)) (raise (make-error)))))
(with-test-prefix "guile condition conversions"
(define-syntax-rule (pass-if-condition name expected-condition? body ...)
(pass-if name
(guard (obj ((expected-condition? obj) #t)
(else #f))
body ... #f)))
(pass-if "rethrown native guile exceptions"
(catch #t
(lambda ()
(guard (obj ((syntax-violation? obj) #f))
(vector-ref '#(0 1) 2)
#f))
(lambda (key . args)
(eq? key 'out-of-range))))
(pass-if-condition "syntax-error"
syntax-violation?
(eval '(let) (current-module)))
(pass-if-condition "unbound-variable"
undefined-violation?
variable-that-does-not-exist)
(pass-if-condition "out-of-range"
assertion-violation?
(vector-ref '#(0 1) 2))
(pass-if-condition "wrong-number-of-args"
assertion-violation?
((lambda () #f) 'unwanted-argument))
(pass-if-condition "wrong-type-arg"
assertion-violation?
(vector-ref '#(0 1) 'invalid-index))
(pass-if-condition "keyword-argument-error"
assertion-violation?
((lambda* (#:key a) #f) #:unwanted-keyword 'val))
(pass-if-condition "regular-expression-syntax"
assertion-violation?
(make-regexp "[missing-close-square-bracket"))
(pass-if-condition "null-pointer-error"
assertion-violation?
(dereference-pointer (make-pointer 0)))
(pass-if-condition "read-error"
lexical-violation?
(read (open-input-string "(missing-close-paren"))))
;;; Local Variables:
;;; eval: (put 'pass-if-condition 'scheme-indent-function 1)
;;; End: