test-suite/tests/srfi-34.test

   1 ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2003 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., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19
  20 (define-module (test-suite test-srfi-34)
  21   :use-module (test-suite lib)
  22   :use-module (srfi srfi-13)
  23   :use-module (srfi srfi-34))
  24
  25 (define (expr-prints-and-evals-to? expr printout result)
  26   (let ((actual-result *unspecified*))
  27     (let ((actual-printout
  28            (string-trim-both
  29             (with-output-to-string
  30               (lambda ()
  31                 (set! actual-result
  32                       (eval expr (current-module))))))))
  33       ;;(write (list actual-printout printout actual-result result))
  34       ;;(newline)
  35       (and (equal? actual-printout printout)
  36            (equal? actual-result result)))))
  37
  38 (with-test-prefix "SRFI 34"
  39
  40   (pass-if "example 1"
  41            (expr-prints-and-evals-to?
  42             '(call-with-current-continuation
  43               (lambda (k)
  44                 (with-exception-handler (lambda (x)
  45                                           (display "condition: ")
  46                                           (write x)
  47                                           (newline)
  48                                           (k 'exception))
  49                                         (lambda ()
  50                                           (+ 1 (raise 'an-error))))))
  51             "condition: an-error"
  52             'exception))
  53
  54   ;; SRFI 34 specifies that the behaviour of the call/cc expression
  55   ;; after printing "something went wrong" is unspecified, which is
  56   ;; tricky to test for in a positive way ...  Guile behaviour at time
  57   ;; of writing is to signal a "lazy-catch handler did return" error,
  58   ;; which feels about right to me.
  59   (pass-if "example 2"
  60            (expr-prints-and-evals-to?
  61             '(false-if-exception
  62               (call-with-current-continuation
  63                (lambda (k)
  64                  (with-exception-handler (lambda (x)
  65                                            (display "something went wrong")
  66                                            (newline)
  67                                            'dont-care)
  68                                          (lambda ()
  69                                            (+ 1 (raise 'an-error)))))))
  70             "something went wrong"
  71             #f))
  72
  73   (pass-if "example 3"
  74            (expr-prints-and-evals-to?
  75             '(guard (condition
  76                      (else
  77                       (display "condition: ")
  78                       (write condition)
  79                       (newline)
  80                       'exception))
  81                     (+ 1 (raise 'an-error)))
  82             "condition: an-error"
  83             'exception))
  84
  85   (pass-if "example 4"
  86            (expr-prints-and-evals-to?
  87             '(guard (condition
  88                      (else
  89                       (display "something went wrong")
  90                       (newline)
  91                       'dont-care))
  92                     (+ 1 (raise 'an-error)))
  93             "something went wrong"
  94             'dont-care))
  95
  96   (pass-if "example 5"
  97            (expr-prints-and-evals-to?
  98             '(call-with-current-continuation
  99               (lambda (k)
 100                 (with-exception-handler (lambda (x)
 101                                           (display "reraised ") (write x) (newline)
 102                                           (k 'zero))
 103                                         (lambda ()
 104                                           (guard (condition
 105                                                   ((positive? condition) 'positive)
 106                                                   ((negative? condition) 'negative))
 107                                                  (raise 1))))))
 108             ""
 109             'positive))
 110
 111   (pass-if "example 6"
 112            (expr-prints-and-evals-to?
 113             '(call-with-current-continuation
 114               (lambda (k)
 115                 (with-exception-handler (lambda (x)
 116                                           (display "reraised ") (write x) (newline)
 117                                           (k 'zero))
 118                                         (lambda ()
 119                                           (guard (condition
 120                                                   ((positive? condition) 'positive)
 121                                                   ((negative? condition) 'negative))
 122                                                  (raise -1))))))
 123             ""
 124             'negative))
 125
 126   (pass-if "example 7"
 127            (expr-prints-and-evals-to?
 128             '(call-with-current-continuation
 129               (lambda (k)
 130                 (with-exception-handler (lambda (x)
 131                                           (display "reraised ") (write x) (newline)
 132                                           (k 'zero))
 133                                         (lambda ()
 134                                           (guard (condition
 135                                                   ((positive? condition) 'positive)
 136                                                   ((negative? condition) 'negative))
 137                                                  (raise 0))))))
 138             "reraised 0"
 139             'zero))
 140
 141   (pass-if "example 8"
 142            (expr-prints-and-evals-to?
 143             '(guard (condition
 144                      ((assq 'a condition) => cdr)
 145                      ((assq 'b condition)))
 146                     (raise (list (cons 'a 42))))
 147             ""
 148             42))
 149
 150   (pass-if "example 9"
 151            (expr-prints-and-evals-to?
 152             '(guard (condition
 153                      ((assq 'a condition) => cdr)
 154                      ((assq 'b condition)))
 155                     (raise (list (cons 'b 23))))
 156             ""
 157             '(b . 23)))
 158
 159 )