[bpt/guile.git] / test-suite / tests / exceptions.test

;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA


(use-modules (test-suite lib))

(define-syntax-parameter push
  (lambda (stx)
    (syntax-violation 'push "push used outside of throw-test" stx)))

(define-syntax-rule (throw-test title result expr ...)
  (pass-if title
    (equal? result
            (let ((stack '()))
              (syntax-parameterize ((push (syntax-rules ()
                                            ((push val)
                                             (set! stack (cons val stack))))))
                expr ...
                ;;(format #t "~a: ~s~%" title (reverse stack))
                (reverse stack))))))

(with-test-prefix "throw/catch"

  (with-test-prefix "wrong type argument"

    (pass-if-exception "(throw 1)"
      exception:wrong-type-arg
      (throw 1)))

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "(throw)"
      exception:wrong-num-args
      (throw))

    (pass-if-exception "throw 1 / catch 0"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda () #f)))

    (pass-if-exception "throw 2 / catch 1"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a 2))
	(lambda (x) #f)))

    (pass-if-exception "throw 1 / catch 2"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda (x y) #f)))

    (pass-if-exception "throw 3 / catch 2"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a 2 3))
	(lambda (y x) #f)))

    (pass-if-exception "throw 1 / catch 2+"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda (x y . rest) #f))))

  (with-test-prefix "with pre-unwind handler"

    (pass-if "pre-unwind fluid state"
      (equal? '(inner outer arg)
       (let ((fluid-parm (make-fluid))
	     (inner-val #f))
	 (fluid-set! fluid-parm 'outer)
	 (catch 'misc-exc
	   (lambda ()
	     (with-fluids ((fluid-parm 'inner))
	       (throw 'misc-exc 'arg)))
	   (lambda (key . args)
	     (list inner-val
		   (fluid-ref fluid-parm)
		   (car args)))
	   (lambda (key . args)
	     (set! inner-val (fluid-ref fluid-parm))))))))

  (throw-test "normal catch"
	      '(1 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))))

  (throw-test "catch and with-throw-handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler
                        'a
                        (lambda ()
                          (push 2)
                          (throw 'a))
                        (lambda (key . args)
                          (push 3))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with rethrowing throw-handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler
                        'a
                        (lambda ()
                          (push 2)
                          (throw 'a))
                        (lambda (key . args)
                          (push 3)
                          (apply throw key args))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with pre-unwind handler"
	      '(1 3 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))
		     (lambda (key . args)
		       (push 3))))

  (throw-test "catch with rethrowing pre-unwind handler"
	      '(1 3 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))
		     (lambda (key . args)
		       (push 3)
		       (apply throw key args))))

  (throw-test "catch with throw handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'a
					   (lambda ()
					     (push 2)
					     (throw 'a))
					   (lambda (key . args)
					     (push 3))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with rethrowing throw handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'a
					   (lambda ()
					     (push 2)
					     (throw 'a))
					   (lambda (key . args)
					     (push 3)
					     (apply throw key args))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
	      '(1 2 3 5 4 6)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'b
				   (lambda ()
				     (push 2)
				     (catch 'a
					    (lambda ()
					      (push 3)
					      (throw 'b))
					    (lambda (key . args)
					      (push 4))))
				   (lambda (key . args)
				     (push 5)
				     (throw 'a)))
		       (push 6))
		     (lambda (key . args)
		       (push 7))))

  (throw-test "with-throw-handler chaining"
	      '(1 2 3 4 6 8)
	      (catch 'a
	        (lambda ()
		  (push 1)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 2)
		      (with-throw-handler 'a
                        (lambda ()
			  (push 3)
			  (throw 'a))
			(lambda (key . args)
			  (push 4)))
		      (push 5))
		    (lambda (key . args)
		      (push 6)))
		  (push 7))
		(lambda (key . args)
		  (push 8))))

  (throw-test "throw handlers throwing to each other recursively"
	      '(1 2 3 4 8 6 10 12)
	      (catch #t
                (lambda ()
		  (push 1)
		  (with-throw-handler 'a
                    (lambda ()
		      (push 2)
		      (with-throw-handler 'b
		        (lambda ()
			  (push 3)
			  (with-throw-handler 'c
			    (lambda ()
			      (push 4)
			      (throw 'b)
			      (push 5))
			    (lambda (key . args)
			      (push 6)
			      (throw 'a)))
			  (push 7))
			(lambda (key . args)
			  (push 8)
			  (throw 'c)))
		      (push 9))
		    (lambda (key . args)
		      (push 10)
		      (throw 'b)))
		  (push 11))
		(lambda (key . args)
		  (push 12))))

  (throw-test "throw handler throwing to lexically inside catch"
	      '(1 2 7 5 4 6 9)
	      (with-throw-handler 'a
				  (lambda ()
				    (push 1)
				    (catch 'b
					   (lambda ()
					     (push 2)
					     (throw 'a)
					     (push 3))
					   (lambda (key . args)
					     (push 4))
					   (lambda (key . args)
					     (push 5)))
				    (push 6))
				  (lambda (key . args)
				    (push 7)
				    (throw 'b)
				    (push 8)))
	      (push 9))

  (throw-test "reuse of same throw handler after lexically inside catch"
	      '(0 1 2 7 5 4 6 7 10)
	      (catch 'b
	        (lambda ()
		  (push 0)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 1)
		      (catch 'b
		        (lambda ()
			  (push 2)
			  (throw 'a)
			  (push 3))
			(lambda (key . args)
			  (push 4))
			(lambda (key . args)
			  (push 5)))
		      (push 6)
		      (throw 'a))
		    (lambda (key . args)
		      (push 7)
		      (throw 'b)
		      (push 8)))
		  (push 9))
		(lambda (key . args)
		  (push 10))))

  (throw-test "again but with two chained throw handlers"
	      '(0 1 11 2 13 7 5 4 12 13 7 10)
	      (catch 'b
	        (lambda ()
		  (push 0)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 1)
		      (with-throw-handler 'a
		        (lambda ()
			  (push 11)
			  (catch 'b
			    (lambda ()
			      (push 2)
			      (throw 'a)
			      (push 3))
			    (lambda (key . args)
			      (push 4))
			    (lambda (key . args)
			      (push 5)))
			  (push 12)
			  (throw 'a))
			(lambda (key . args)
			  (push 13)))
		      (push 6))
		    (lambda (key . args)
		      (push 7)
		      (throw 'b)))
		  (push 9))
		(lambda (key . args)
		  (push 10))))

  )

(with-test-prefix "false-if-exception"

  (pass-if (false-if-exception #t))
  (pass-if (not (false-if-exception #f)))
  (pass-if (not (false-if-exception (error "xxx"))))

  ;; Not yet working.
  ;;
  ;; (with-test-prefix "in empty environment"
  ;;   ;; an environment with no bindings at all
  ;;   (define empty-environment
  ;;     (make-module 1))
  ;;
  ;;   (pass-if "#t"
  ;;     (eval `(,false-if-exception #t)
  ;; 	    empty-environment))
  ;;   (pass-if "#f"
  ;;     (not (eval `(,false-if-exception #f)
  ;; 		 empty-environment)))
  ;;   (pass-if "exception"
  ;;     (not (eval `(,false-if-exception (,error "xxx"))
  ;;                empty-environment))))
  )
Commit	Line	Data
08c608e1	1	;;;; exceptions.test --- tests for Guile's exception handling -- scheme --
e10cf6b9	2	;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 Free Software Foundation, Inc.
cf7b149f	3	;;;;
73be1d9e MV	4	;;;; This library is free software; you can redistribute it and/or
	5	;;;; modify it under the terms of the GNU Lesser General Public
	6	;;;; License as published by the Free Software Foundation; either
53befeb7	7	;;;; version 3 of the License, or (at your option) any later version.
73be1d9e MV	8	;;;;
73be1d9e MV	9	;;;; This library is distributed in the hope that it will be useful,
cf7b149f	10	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	11	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;;;; Lesser General Public License for more details.
	13	;;;;
	14	;;;; You should have received a copy of the GNU Lesser General Public
	15	;;;; License along with this library; if not, write to the Free Software
92205699	16	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
cf7b149f	17
cf7b149f	18
9bc915bb KR	19	(use-modules (test-suite lib))
9bc915bb KR	20
1e42832a CJY	21	(define-syntax-parameter push
	22	(lambda (stx)
	23	(syntax-violation 'push "push used outside of throw-test" stx)))
	24
	25	(define-syntax-rule (throw-test title result expr ...)
	26	(pass-if title
	27	(equal? result
	28	(let ((stack '()))
	29	(syntax-parameterize ((push (syntax-rules ()
	30	((push val)
	31	(set! stack (cons val stack))))))
	32	expr ...
	33	;;(format #t "~a: ~s~%" title (reverse stack))
	34	(reverse stack))))))
26beee1e	35
08c608e1	36	(with-test-prefix "throw/catch"
cf7b149f	37
08c608e1	38	(with-test-prefix "wrong type argument"
cf7b149f	39
08c608e1 DH	40	(pass-if-exception "(throw 1)"
	41	exception:wrong-type-arg
	42	(throw 1)))
cf7b149f	43
08c608e1	44	(with-test-prefix "wrong number of arguments"
cf7b149f	45
08c608e1 DH	46	(pass-if-exception "(throw)"
	47	exception:wrong-num-args
	48	(throw))
cf7b149f	49
08c608e1 DH	50	(pass-if-exception "throw 1 / catch 0"
	51	exception:wrong-num-args
	52	(catch 'a
	53	(lambda () (throw 'a))
	54	(lambda () #f)))
cf7b149f	55
08c608e1 DH	56	(pass-if-exception "throw 2 / catch 1"
	57	exception:wrong-num-args
	58	(catch 'a
	59	(lambda () (throw 'a 2))
	60	(lambda (x) #f)))
1b5b19c9	61
08c608e1 DH	62	(pass-if-exception "throw 1 / catch 2"
	63	exception:wrong-num-args
	64	(catch 'a
	65	(lambda () (throw 'a))
	66	(lambda (x y) #f)))
cf7b149f	67
08c608e1 DH	68	(pass-if-exception "throw 3 / catch 2"
	69	exception:wrong-num-args
	70	(catch 'a
	71	(lambda () (throw 'a 2 3))
	72	(lambda (y x) #f)))
cf7b149f	73
08c608e1 DH	74	(pass-if-exception "throw 1 / catch 2+"
	75	exception:wrong-num-args
	76	(catch 'a
	77	(lambda () (throw 'a))
26beee1e NJ	78	(lambda (x y . rest) #f))))
26beee1e NJ	79
e10cf6b9	80	(with-test-prefix "with pre-unwind handler"
26beee1e	81
e10cf6b9	82	(pass-if "pre-unwind fluid state"
26beee1e NJ	83	(equal? '(inner outer arg)
	84	(let ((fluid-parm (make-fluid))
	85	(inner-val #f))
	86	(fluid-set! fluid-parm 'outer)
	87	(catch 'misc-exc
	88	(lambda ()
	89	(with-fluids ((fluid-parm 'inner))
	90	(throw 'misc-exc 'arg)))
	91	(lambda (key . args)
	92	(list inner-val
	93	(fluid-ref fluid-parm)
	94	(car args)))
	95	(lambda (key . args)
	96	(set! inner-val (fluid-ref fluid-parm))))))))
	97
	98	(throw-test "normal catch"
	99	'(1 2)
	100	(catch 'a
	101	(lambda ()
	102	(push 1)
	103	(throw 'a))
	104	(lambda (key . args)
	105	(push 2))))
	106
e10cf6b9	107	(throw-test "catch and with-throw-handler"
26beee1e NJ	108	'(1 2 3 4)
	109	(catch 'a
	110	(lambda ()
	111	(push 1)
e10cf6b9 AW	112	(with-throw-handler
	113	'a
	114	(lambda ()
	115	(push 2)
	116	(throw 'a))
	117	(lambda (key . args)
	118	(push 3))))
26beee1e NJ	119	(lambda (key . args)
	120	(push 4))))
	121
e10cf6b9	122	(throw-test "catch with rethrowing throw-handler"
26beee1e NJ	123	'(1 2 3 4)
	124	(catch 'a
	125	(lambda ()
	126	(push 1)
e10cf6b9 AW	127	(with-throw-handler
	128	'a
	129	(lambda ()
	130	(push 2)
	131	(throw 'a))
	132	(lambda (key . args)
	133	(push 3)
	134	(apply throw key args))))
26beee1e NJ	135	(lambda (key . args)
	136	(push 4))))
	137
	138	(throw-test "catch with pre-unwind handler"
	139	'(1 3 2)
	140	(catch 'a
	141	(lambda ()
	142	(push 1)
	143	(throw 'a))
	144	(lambda (key . args)
	145	(push 2))
	146	(lambda (key . args)
	147	(push 3))))
	148
	149	(throw-test "catch with rethrowing pre-unwind handler"
	150	'(1 3 2)
	151	(catch 'a
	152	(lambda ()
	153	(push 1)
	154	(throw 'a))
	155	(lambda (key . args)
	156	(push 2))
	157	(lambda (key . args)
	158	(push 3)
	159	(apply throw key args))))
	160
	161	(throw-test "catch with throw handler"
	162	'(1 2 3 4)
	163	(catch 'a
	164	(lambda ()
	165	(push 1)
	166	(with-throw-handler 'a
	167	(lambda ()
	168	(push 2)
	169	(throw 'a))
	170	(lambda (key . args)
	171	(push 3))))
	172	(lambda (key . args)
	173	(push 4))))
	174
	175	(throw-test "catch with rethrowing throw handler"
	176	'(1 2 3 4)
	177	(catch 'a
	178	(lambda ()
	179	(push 1)
	180	(with-throw-handler 'a
	181	(lambda ()
	182	(push 2)
	183	(throw 'a))
	184	(lambda (key . args)
	185	(push 3)
	186	(apply throw key args))))
	187	(lambda (key . args)
	188	(push 4))))
	189
26beee1e NJ	190	(throw-test "effect of with-throw-handler not-unwinding on throw to another key"
	191	'(1 2 3 5 4 6)
	192	(catch 'a
	193	(lambda ()
	194	(push 1)
	195	(with-throw-handler 'b
	196	(lambda ()
	197	(push 2)
	198	(catch 'a
	199	(lambda ()
	200	(push 3)
	201	(throw 'b))
	202	(lambda (key . args)
	203	(push 4))))
	204	(lambda (key . args)
	205	(push 5)
	206	(throw 'a)))
	207	(push 6))
	208	(lambda (key . args)
	209	(push 7))))
	210
26beee1e NJ	211	(throw-test "with-throw-handler chaining"
	212	'(1 2 3 4 6 8)
	213	(catch 'a
	214	(lambda ()
	215	(push 1)
	216	(with-throw-handler 'a
	217	(lambda ()
	218	(push 2)
	219	(with-throw-handler 'a
	220	(lambda ()
	221	(push 3)
	222	(throw 'a))
	223	(lambda (key . args)
	224	(push 4)))
	225	(push 5))
	226	(lambda (key . args)
	227	(push 6)))
	228	(push 7))
	229	(lambda (key . args)
	230	(push 8))))
	231
26beee1e NJ	232	(throw-test "throw handlers throwing to each other recursively"
	233	'(1 2 3 4 8 6 10 12)
	234	(catch #t
	235	(lambda ()
	236	(push 1)
	237	(with-throw-handler 'a
	238	(lambda ()
	239	(push 2)
	240	(with-throw-handler 'b
	241	(lambda ()
	242	(push 3)
	243	(with-throw-handler 'c
	244	(lambda ()
	245	(push 4)
	246	(throw 'b)
	247	(push 5))
	248	(lambda (key . args)
	249	(push 6)
	250	(throw 'a)))
	251	(push 7))
	252	(lambda (key . args)
	253	(push 8)
	254	(throw 'c)))
	255	(push 9))
	256	(lambda (key . args)
	257	(push 10)
	258	(throw 'b)))
	259	(push 11))
	260	(lambda (key . args)
	261	(push 12))))
	262
26beee1e NJ	263	(throw-test "throw handler throwing to lexically inside catch"
	264	'(1 2 7 5 4 6 9)
	265	(with-throw-handler 'a
	266	(lambda ()
	267	(push 1)
	268	(catch 'b
	269	(lambda ()
	270	(push 2)
	271	(throw 'a)
	272	(push 3))
	273	(lambda (key . args)
	274	(push 4))
	275	(lambda (key . args)
	276	(push 5)))
	277	(push 6))
	278	(lambda (key . args)
	279	(push 7)
	280	(throw 'b)
	281	(push 8)))
	282	(push 9))
	283
	284	(throw-test "reuse of same throw handler after lexically inside catch"
	285	'(0 1 2 7 5 4 6 7 10)
	286	(catch 'b
	287	(lambda ()
	288	(push 0)
	289	(with-throw-handler 'a
	290	(lambda ()
	291	(push 1)
	292	(catch 'b
	293	(lambda ()
	294	(push 2)
	295	(throw 'a)
	296	(push 3))
	297	(lambda (key . args)
	298	(push 4))
	299	(lambda (key . args)
	300	(push 5)))
	301	(push 6)
	302	(throw 'a))
	303	(lambda (key . args)
	304	(push 7)
	305	(throw 'b)
	306	(push 8)))
	307	(push 9))
	308	(lambda (key . args)
	309	(push 10))))
	310
	311	(throw-test "again but with two chained throw handlers"
	312	'(0 1 11 2 13 7 5 4 12 13 7 10)
	313	(catch 'b
	314	(lambda ()
	315	(push 0)
	316	(with-throw-handler 'a
	317	(lambda ()
	318	(push 1)
	319	(with-throw-handler 'a
	320	(lambda ()
	321	(push 11)
	322	(catch 'b
	323	(lambda ()
	324	(push 2)
	325	(throw 'a)
	326	(push 3))
327	(lambda (key . args)
328	(push 4))
329	(lambda (key . args)
330	(push 5)))
331	(push 12)
332	(throw 'a))
333	(lambda (key . args)
334	(push 13)))
335	(push 6))
336	(lambda (key . args)
337	(push 7)
338	(throw 'b)))
339	(push 9))
340	(lambda (key . args)
341	(push 10))))
342
343	)
9bc915bb KR	344
9bc915bb KR	345	(with-test-prefix "false-if-exception"
8081c3fb	346
9bc915bb KR	347	(pass-if (false-if-exception #t))
	348	(pass-if (not (false-if-exception #f)))
	349	(pass-if (not (false-if-exception (error "xxx"))))
8081c3fb KR	350
	351	;; Not yet working.
	352	;;
	353	;; (with-test-prefix "in empty environment"
	354	;; ;; an environment with no bindings at all
	355	;; (define empty-environment
	356	;; (make-module 1))
	357	;;
	358	;; (pass-if "#t"
	359	;; (eval `(,false-if-exception #t)
	360	;; empty-environment))
	361	;; (pass-if "#f"
	362	;; (not (eval `(,false-if-exception #f)
	363	;; empty-environment)))
	364	;; (pass-if "exception"
	365	;; (not (eval `(,false-if-exception (,error "xxx"))
	366	;; empty-environment))))
	367	)