SRFI 34

test-suite/ChangeLog

@@ -1,3 +1,9 @@
+2003-04-30  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* Makefile.am (SCM_TESTS): Add tests/srfi-34.test.
+
+	* tests/srfi-34.test: New file.
+
 2003-04-23  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* tests/syntax.test: Modified some tests to use eval when

test-suite/Makefile.am

@@ -31,6 +31,7 @@ SCM_TESTS = tests/alist.test			\
 	    tests/srfi-13.test			\
 	    tests/srfi-14.test			\
 	    tests/srfi-19.test			\
+	    tests/srfi-34.test			\
 	    tests/srfi-4.test			\
 	    tests/srfi-9.test			\
 	    tests/strings.test			\

test-suite/tests/srfi-34.test

@@ -0,0 +1,159 @@
+;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
+;;;;
+;;;; 	Copyright (C) 2003 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(define-module (test-suite test-srfi-34)
+  :use-module (test-suite lib)
+  :use-module (srfi srfi-13)
+  :use-module (srfi srfi-34))
+
+(define (expr-prints-and-evals-to? expr printout result)
+  (let ((actual-result *unspecified*))
+    (let ((actual-printout
+	   (string-trim-both
+	    (with-output-to-string
+	      (lambda ()
+		(set! actual-result
+		      (eval expr (current-module))))))))
+      ;;(write (list actual-printout printout actual-result result))
+      ;;(newline)
+      (and (equal? actual-printout printout)
+	   (equal? actual-result result)))))
+
+(with-test-prefix "SRFI 34"
+
+  (pass-if "example 1"
+	   (expr-prints-and-evals-to?
+	    '(call-with-current-continuation
+	      (lambda (k)
+		(with-exception-handler (lambda (x)
+					  (display "condition: ")
+					  (write x)
+					  (newline)
+					  (k 'exception))
+					(lambda ()
+					  (+ 1 (raise 'an-error))))))
+	    "condition: an-error"
+	    'exception))
+
+  ;; SRFI 34 specifies that the behaviour of the call/cc expression
+  ;; after printing "something went wrong" is unspecified, which is
+  ;; tricky to test for in a positive way ...  Guile behaviour at time
+  ;; of writing is to signal a "lazy-catch handler did return" error,
+  ;; which feels about right to me.
+  (pass-if "example 2"
+	   (expr-prints-and-evals-to?
+	    '(false-if-exception 
+	      (call-with-current-continuation
+	       (lambda (k)
+		 (with-exception-handler (lambda (x)
+					   (display "something went wrong")
+					   (newline)
+					   'dont-care)
+					 (lambda ()
+					   (+ 1 (raise 'an-error)))))))
+	    "something went wrong"
+	    #f))
+	   
+  (pass-if "example 3"
+	   (expr-prints-and-evals-to?
+	    '(guard (condition
+		     (else
+		      (display "condition: ")
+		      (write condition)
+		      (newline)
+		      'exception))
+		    (+ 1 (raise 'an-error)))
+	    "condition: an-error"
+	    'exception))
+
+  (pass-if "example 4"
+	   (expr-prints-and-evals-to?
+	    '(guard (condition
+		     (else
+		      (display "something went wrong")
+		      (newline)
+		      'dont-care))
+		    (+ 1 (raise 'an-error)))
+	    "something went wrong"
+	    'dont-care))
+
+  (pass-if "example 5"
+	   (expr-prints-and-evals-to?
+	    '(call-with-current-continuation
+	      (lambda (k)
+		(with-exception-handler (lambda (x)
+					  (display "reraised ") (write x) (newline)
+					  (k 'zero))
+					(lambda ()
+					  (guard (condition
+						  ((positive? condition) 'positive)
+						  ((negative? condition) 'negative))
+						 (raise 1))))))
+	    ""
+	    'positive))
+
+  (pass-if "example 6"
+	   (expr-prints-and-evals-to?
+	    '(call-with-current-continuation
+	      (lambda (k)
+		(with-exception-handler (lambda (x)
+					  (display "reraised ") (write x) (newline)
+					  (k 'zero))
+					(lambda ()
+					  (guard (condition
+						  ((positive? condition) 'positive)
+						  ((negative? condition) 'negative))
+						 (raise -1))))))
+	    ""
+	    'negative))
+
+  (pass-if "example 7"
+	   (expr-prints-and-evals-to?
+	    '(call-with-current-continuation
+	      (lambda (k)
+		(with-exception-handler (lambda (x)
+					  (display "reraised ") (write x) (newline)
+					  (k 'zero))
+					(lambda ()
+					  (guard (condition
+						  ((positive? condition) 'positive)
+						  ((negative? condition) 'negative))
+						 (raise 0))))))
+	    "reraised 0"
+	    'zero))
+
+  (pass-if "example 8"
+	   (expr-prints-and-evals-to?
+	    '(guard (condition
+		     ((assq 'a condition) => cdr)
+		     ((assq 'b condition)))
+		    (raise (list (cons 'a 42))))
+	    ""
+	    42))
+
+  (pass-if "example 9"
+	   (expr-prints-and-evals-to?
+	    '(guard (condition
+		     ((assq 'a condition) => cdr)
+		     ((assq 'b condition)))
+		    (raise (list (cons 'b 23))))
+	    ""
+	    '(b . 23)))
+
+)