guile18/test-suite/tests/srfi-34.test

   1 ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program 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
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;;;; Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite test-srfi-34)
  21   :duplicates (last)  ;; avoid warning about srfi-34 replacing `raise'
  22   :use-module (test-suite lib)
  23   :use-module (srfi srfi-13)
  24   :use-module (srfi srfi-34))
  25
  26 (define (expr-prints-and-evals-to? expr printout result)
  27   (let ((actual-result *unspecified*))
  28     (let ((actual-printout
  29            (string-trim-both
  30             (with-output-to-string
  31               (lambda ()
  32                 (set! actual-result
  33                       (eval expr (current-module))))))))
  34       ;;(write (list actual-printout printout actual-result result))
  35       ;;(newline)
  36       (and (equal? actual-printout printout)
  37            (equal? actual-result result)))))
  38
  39 (with-test-prefix "SRFI 34"
  40
  41   (pass-if "cond-expand"
  42     (cond-expand (srfi-34 #t)
  43                  (else    #f)))
  44
  45   (pass-if "example 1"
  46            (expr-prints-and-evals-to?
  47             '(call-with-current-continuation
  48               (lambda (k)
  49                 (with-exception-handler (lambda (x)
  50                                           (display "condition: ")
  51                                           (write x)
  52                                           (newline)
  53                                           (k 'exception))
  54                                         (lambda ()
  55                                           (+ 1 (raise 'an-error))))))
  56             "condition: an-error"
  57             'exception))
  58
  59   ;; SRFI 34 specifies that the behaviour of the call/cc expression
  60   ;; after printing "something went wrong" is unspecified, which is
  61   ;; tricky to test for in a positive way ...  Guile behaviour at time
  62   ;; of writing is to signal a "lazy-catch handler did return" error,
  63   ;; which feels about right to me.
  64   (pass-if "example 2"
  65            (expr-prints-and-evals-to?
  66             '(false-if-exception
  67               (call-with-current-continuation
  68                (lambda (k)
  69                  (with-exception-handler (lambda (x)
  70                                            (display "something went wrong")
  71                                            (newline)
  72                                            'dont-care)
  73                                          (lambda ()
  74                                            (+ 1 (raise 'an-error)))))))
  75             "something went wrong"
  76             #f))
  77
  78   (pass-if "example 3"
  79            (expr-prints-and-evals-to?
  80             '(guard (condition
  81                      (else
  82                       (display "condition: ")
  83                       (write condition)
  84                       (newline)
  85                       'exception))
  86                     (+ 1 (raise 'an-error)))
  87             "condition: an-error"
  88             'exception))
  89
  90   (pass-if "example 4"
  91            (expr-prints-and-evals-to?
  92             '(guard (condition
  93                      (else
  94                       (display "something went wrong")
  95                       (newline)
  96                       'dont-care))
  97                     (+ 1 (raise 'an-error)))
  98             "something went wrong"
  99             'dont-care))
 100
 101   (pass-if "example 5"
 102            (expr-prints-and-evals-to?
 103             '(call-with-current-continuation
 104               (lambda (k)
 105                 (with-exception-handler (lambda (x)
 106                                           (display "reraised ") (write x) (newline)
 107                                           (k 'zero))
 108                                         (lambda ()
 109                                           (guard (condition
 110                                                   ((positive? condition) 'positive)
 111                                                   ((negative? condition) 'negative))
 112                                                  (raise 1))))))
 113             ""
 114             'positive))
 115
 116   (pass-if "example 6"
 117            (expr-prints-and-evals-to?
 118             '(call-with-current-continuation
 119               (lambda (k)
 120                 (with-exception-handler (lambda (x)
 121                                           (display "reraised ") (write x) (newline)
 122                                           (k 'zero))
 123                                         (lambda ()
 124                                           (guard (condition
 125                                                   ((positive? condition) 'positive)
 126                                                   ((negative? condition) 'negative))
 127                                                  (raise -1))))))
 128             ""
 129             'negative))
 130
 131   (pass-if "example 7"
 132            (expr-prints-and-evals-to?
 133             '(call-with-current-continuation
 134               (lambda (k)
 135                 (with-exception-handler (lambda (x)
 136                                           (display "reraised ") (write x) (newline)
 137                                           (k 'zero))
 138                                         (lambda ()
 139                                           (guard (condition
 140                                                   ((positive? condition) 'positive)
 141                                                   ((negative? condition) 'negative))
 142                                                  (raise 0))))))
 143             "reraised 0"
 144             'zero))
 145
 146   (pass-if "example 8"
 147            (expr-prints-and-evals-to?
 148             '(guard (condition
 149                      ((assq 'a condition) => cdr)
 150                      ((assq 'b condition)))
 151                     (raise (list (cons 'a 42))))
 152             ""
 153             42))
 154
 155   (pass-if "example 9"
 156            (expr-prints-and-evals-to?
 157             '(guard (condition
 158                      ((assq 'a condition) => cdr)
 159                      ((assq 'b condition)))
 160                     (raise (list (cons 'b 23))))
 161             ""
 162             '(b . 23)))
 163
 164   (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
 165            ;; In Guile 1.8.5 and earlier, unwinders would be called before
 166            ;; the exception handler, which reads "The handler is called in
 167            ;; the dynamic environment of the call to `raise'".
 168            (call/cc
 169             (lambda (return)
 170               (let ((inside? #f))
 171                 (with-exception-handler
 172                  (lambda (c)
 173                    ;; This handler must be called before the unwinder below.
 174                    (return inside?))
 175                  (lambda ()
 176                    (dynamic-wind
 177                      (lambda ()
 178                        (set! inside? #t))
 179                      (lambda ()
 180                        (raise 'some-exception))
 181                      (lambda ()
 182                        ;; This unwinder should not be executed before the
 183                        ;; handler is called.
 184                        (set! inside? #f))))))))))