test-suite/tests/r6rs-exceptions.test

   1 ;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)  -*- scheme -*-
   2
   3 ;;      Copyright (C) 2010, 2013 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 02110-1301 USA
  18 \f
  19
  20 (define-module (test-suite test-rnrs-exceptions)
  21   :use-module ((rnrs conditions) :version (6))
  22   :use-module ((rnrs exceptions) :version (6))
  23   :use-module (system foreign)
  24   :use-module (test-suite lib))
  25
  26 (with-test-prefix "with-exception-handler"
  27   (pass-if "handler invoked on raise"
  28     (let ((success #f))
  29       (call/cc
  30        (lambda (continuation)
  31          (with-exception-handler
  32           (lambda (condition) (set! success #t) (continuation))
  33           (lambda () (raise (make-violation))))))
  34       success))
  35
  36   (pass-if "handler not invoked unless raise"
  37     (let ((success #f))
  38       (call/cc
  39        (lambda (continuation)
  40          (with-exception-handler
  41           (lambda (condition) (continuation))
  42           (lambda () (set! success #t)))))
  43       success)))
  44
  45 (with-test-prefix "raise"
  46   (pass-if "raise causes &non-continuable after handler"
  47     (let ((success #f))
  48       (call/cc
  49        (lambda (continuation)
  50          (with-exception-handler
  51           (lambda (condition)
  52             (set! success (non-continuable-violation? condition))
  53             (continuation))
  54           (lambda ()
  55             (with-exception-handler
  56              (lambda (condition) #f)
  57              (lambda () (raise (make-violation))))))))
  58       success)))
  59
  60 (with-test-prefix "raise-continuable"
  61   (pass-if "raise-continuable invokes continuation after handler"
  62     (let ((handled #f)
  63           (continued #f))
  64       (call/cc
  65        (lambda (continuation)
  66          (with-exception-handler
  67           (lambda (condition) (set! handled #t))
  68           (lambda ()
  69             (raise-continuable (make-violation))
  70             (set! continued #t)))))
  71       (and handled continued))))
  72
  73 (with-test-prefix "guard"
  74   (pass-if "guard with matching cond without else"
  75     (let ((success #f))
  76       (guard (condition ((error? condition) (set! success #t)))
  77              (raise (make-error)))
  78       success))
  79
  80   (pass-if "guard without matching cond without else"
  81     (let ((success #f))
  82       (call/cc
  83        (lambda (continuation)
  84          (with-exception-handler
  85           (lambda (condition) (set! success (error? condition)) (continuation))
  86           (lambda ()
  87             (guard (condition ((irritants-condition? condition) #f))
  88                    (raise (make-error)))))))
  89       success))
  90
  91   (pass-if "guard with else and without matching cond"
  92     (let ((success #f))
  93       (guard (condition ((irritants-condition? condition) #f)
  94                         (else (set! success #t)))
  95              (raise (make-error)))
  96       success))
  97
  98   (pass-if "guard with cond => syntax"
  99     (guard (condition (condition => error?)) (raise (make-error)))))
 100
 101 (with-test-prefix "guile condition conversions"
 102
 103   (define-syntax-rule (pass-if-condition name expected-condition? body ...)
 104     (pass-if name
 105       (guard (obj ((expected-condition? obj) #t)
 106                   (else #f))
 107         body ... #f)))
 108
 109   (pass-if "rethrown native guile exceptions"
 110     (catch #t
 111       (lambda ()
 112         (guard (obj ((syntax-violation? obj) #f))
 113           (vector-ref '#(0 1) 2)
 114           #f))
 115       (lambda (key . args)
 116         (eq? key 'out-of-range))))
 117
 118   (pass-if-condition "syntax-error"
 119     syntax-violation?
 120     (eval '(let) (current-module)))
 121
 122   (pass-if-condition "unbound-variable"
 123     undefined-violation?
 124     variable-that-does-not-exist)
 125
 126   (pass-if-condition "out-of-range"
 127     assertion-violation?
 128     (vector-ref '#(0 1) 2))
 129
 130   (pass-if-condition "wrong-number-of-args"
 131     assertion-violation?
 132     ((lambda () #f) 'unwanted-argument))
 133
 134   (pass-if-condition "wrong-type-arg"
 135     assertion-violation?
 136     (vector-ref '#(0 1) 'invalid-index))
 137
 138   (pass-if-condition "keyword-argument-error"
 139     assertion-violation?
 140     ((lambda* (#:key a) #f) #:unwanted-keyword 'val))
 141
 142   (pass-if-condition "regular-expression-syntax"
 143     assertion-violation?
 144     (make-regexp "[missing-close-square-bracket"))
 145
 146   (pass-if-condition "null-pointer-error"
 147     assertion-violation?
 148     (dereference-pointer (make-pointer 0)))
 149
 150   (pass-if-condition "read-error"
 151     lexical-violation?
 152     (read (open-input-string "(missing-close-paren"))))
 153
 154 ;;; Local Variables:
 155 ;;; eval: (put 'pass-if-condition 'scheme-indent-function 1)
 156 ;;; End: