[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-macro (throw-test title result . exprs)
  `(pass-if ,title
     (equal? ,result
	     (letrec ((stack '())
		      (push (lambda (val)
			      (set! stack (cons val stack)))))
	       (begin ,@exprs)
	       ;;(display ,title)
	       ;;(display ": ")
	       ;;(write (reverse stack))
	       ;;(newline)
	       (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
26beee1e NJ	21	(define-macro (throw-test title result . exprs)
	22	`(pass-if ,title
	23	(equal? ,result
	24	(letrec ((stack '())
	25	(push (lambda (val)
	26	(set! stack (cons val stack)))))
	27	(begin ,@exprs)
	28	;;(display ,title)
	29	;;(display ": ")
	30	;;(write (reverse stack))
	31	;;(newline)
	32	(reverse stack)))))
	33
08c608e1	34	(with-test-prefix "throw/catch"
cf7b149f	35
08c608e1	36	(with-test-prefix "wrong type argument"
cf7b149f	37
08c608e1 DH	38	(pass-if-exception "(throw 1)"
	39	exception:wrong-type-arg
	40	(throw 1)))
cf7b149f	41
08c608e1	42	(with-test-prefix "wrong number of arguments"
cf7b149f	43
08c608e1 DH	44	(pass-if-exception "(throw)"
	45	exception:wrong-num-args
	46	(throw))
cf7b149f	47
08c608e1 DH	48	(pass-if-exception "throw 1 / catch 0"
	49	exception:wrong-num-args
	50	(catch 'a
	51	(lambda () (throw 'a))
	52	(lambda () #f)))
cf7b149f	53
08c608e1 DH	54	(pass-if-exception "throw 2 / catch 1"
	55	exception:wrong-num-args
	56	(catch 'a
	57	(lambda () (throw 'a 2))
	58	(lambda (x) #f)))
1b5b19c9	59
08c608e1 DH	60	(pass-if-exception "throw 1 / catch 2"
	61	exception:wrong-num-args
	62	(catch 'a
	63	(lambda () (throw 'a))
	64	(lambda (x y) #f)))
cf7b149f	65
08c608e1 DH	66	(pass-if-exception "throw 3 / catch 2"
	67	exception:wrong-num-args
	68	(catch 'a
	69	(lambda () (throw 'a 2 3))
	70	(lambda (y x) #f)))
cf7b149f	71
08c608e1 DH	72	(pass-if-exception "throw 1 / catch 2+"
	73	exception:wrong-num-args
	74	(catch 'a
	75	(lambda () (throw 'a))
26beee1e NJ	76	(lambda (x y . rest) #f))))
26beee1e NJ	77
e10cf6b9	78	(with-test-prefix "with pre-unwind handler"
26beee1e	79
e10cf6b9	80	(pass-if "pre-unwind fluid state"
26beee1e NJ	81	(equal? '(inner outer arg)
	82	(let ((fluid-parm (make-fluid))
	83	(inner-val #f))
	84	(fluid-set! fluid-parm 'outer)
	85	(catch 'misc-exc
	86	(lambda ()
	87	(with-fluids ((fluid-parm 'inner))
	88	(throw 'misc-exc 'arg)))
	89	(lambda (key . args)
	90	(list inner-val
	91	(fluid-ref fluid-parm)
	92	(car args)))
	93	(lambda (key . args)
	94	(set! inner-val (fluid-ref fluid-parm))))))))
	95
	96	(throw-test "normal catch"
	97	'(1 2)
	98	(catch 'a
	99	(lambda ()
	100	(push 1)
	101	(throw 'a))
	102	(lambda (key . args)
	103	(push 2))))
	104
e10cf6b9	105	(throw-test "catch and with-throw-handler"
26beee1e NJ	106	'(1 2 3 4)
	107	(catch 'a
	108	(lambda ()
	109	(push 1)
e10cf6b9 AW	110	(with-throw-handler
	111	'a
	112	(lambda ()
	113	(push 2)
	114	(throw 'a))
	115	(lambda (key . args)
	116	(push 3))))
26beee1e NJ	117	(lambda (key . args)
	118	(push 4))))
	119
e10cf6b9	120	(throw-test "catch with rethrowing throw-handler"
26beee1e NJ	121	'(1 2 3 4)
	122	(catch 'a
	123	(lambda ()
	124	(push 1)
e10cf6b9 AW	125	(with-throw-handler
	126	'a
	127	(lambda ()
	128	(push 2)
	129	(throw 'a))
	130	(lambda (key . args)
	131	(push 3)
	132	(apply throw key args))))
26beee1e NJ	133	(lambda (key . args)
	134	(push 4))))
	135
	136	(throw-test "catch with pre-unwind handler"
	137	'(1 3 2)
	138	(catch 'a
	139	(lambda ()
	140	(push 1)
	141	(throw 'a))
	142	(lambda (key . args)
	143	(push 2))
	144	(lambda (key . args)
	145	(push 3))))
	146
	147	(throw-test "catch with rethrowing pre-unwind handler"
	148	'(1 3 2)
	149	(catch 'a
	150	(lambda ()
	151	(push 1)
	152	(throw 'a))
	153	(lambda (key . args)
	154	(push 2))
	155	(lambda (key . args)
	156	(push 3)
	157	(apply throw key args))))
	158
	159	(throw-test "catch with throw handler"
	160	'(1 2 3 4)
	161	(catch 'a
	162	(lambda ()
	163	(push 1)
	164	(with-throw-handler 'a
	165	(lambda ()
	166	(push 2)
	167	(throw 'a))
	168	(lambda (key . args)
	169	(push 3))))
	170	(lambda (key . args)
	171	(push 4))))
	172
	173	(throw-test "catch with rethrowing throw handler"
	174	'(1 2 3 4)
	175	(catch 'a
	176	(lambda ()
	177	(push 1)
	178	(with-throw-handler 'a
	179	(lambda ()
	180	(push 2)
	181	(throw 'a))
	182	(lambda (key . args)
	183	(push 3)
	184	(apply throw key args))))
	185	(lambda (key . args)
	186	(push 4))))
	187
26beee1e NJ	188	(throw-test "effect of with-throw-handler not-unwinding on throw to another key"
	189	'(1 2 3 5 4 6)
	190	(catch 'a
	191	(lambda ()
	192	(push 1)
	193	(with-throw-handler 'b
	194	(lambda ()
	195	(push 2)
	196	(catch 'a
	197	(lambda ()
	198	(push 3)
	199	(throw 'b))
	200	(lambda (key . args)
	201	(push 4))))
	202	(lambda (key . args)
	203	(push 5)
	204	(throw 'a)))
	205	(push 6))
	206	(lambda (key . args)
	207	(push 7))))
	208
26beee1e NJ	209	(throw-test "with-throw-handler chaining"
	210	'(1 2 3 4 6 8)
	211	(catch 'a
	212	(lambda ()
	213	(push 1)
	214	(with-throw-handler 'a
	215	(lambda ()
	216	(push 2)
	217	(with-throw-handler 'a
	218	(lambda ()
	219	(push 3)
	220	(throw 'a))
	221	(lambda (key . args)
	222	(push 4)))
	223	(push 5))
	224	(lambda (key . args)
	225	(push 6)))
	226	(push 7))
	227	(lambda (key . args)
	228	(push 8))))
	229
26beee1e NJ	230	(throw-test "throw handlers throwing to each other recursively"
	231	'(1 2 3 4 8 6 10 12)
	232	(catch #t
	233	(lambda ()
	234	(push 1)
	235	(with-throw-handler 'a
	236	(lambda ()
	237	(push 2)
	238	(with-throw-handler 'b
	239	(lambda ()
	240	(push 3)
	241	(with-throw-handler 'c
	242	(lambda ()
	243	(push 4)
	244	(throw 'b)
	245	(push 5))
	246	(lambda (key . args)
	247	(push 6)
	248	(throw 'a)))
	249	(push 7))
	250	(lambda (key . args)
	251	(push 8)
	252	(throw 'c)))
	253	(push 9))
	254	(lambda (key . args)
	255	(push 10)
	256	(throw 'b)))
	257	(push 11))
	258	(lambda (key . args)
	259	(push 12))))
	260
26beee1e NJ	261	(throw-test "throw handler throwing to lexically inside catch"
	262	'(1 2 7 5 4 6 9)
	263	(with-throw-handler 'a
	264	(lambda ()
	265	(push 1)
	266	(catch 'b
	267	(lambda ()
	268	(push 2)
	269	(throw 'a)
	270	(push 3))
	271	(lambda (key . args)
	272	(push 4))
	273	(lambda (key . args)
	274	(push 5)))
	275	(push 6))
	276	(lambda (key . args)
	277	(push 7)
	278	(throw 'b)
	279	(push 8)))
	280	(push 9))
	281
	282	(throw-test "reuse of same throw handler after lexically inside catch"
	283	'(0 1 2 7 5 4 6 7 10)
	284	(catch 'b
	285	(lambda ()
	286	(push 0)
	287	(with-throw-handler 'a
	288	(lambda ()
	289	(push 1)
	290	(catch 'b
	291	(lambda ()
	292	(push 2)
	293	(throw 'a)
	294	(push 3))
	295	(lambda (key . args)
	296	(push 4))
	297	(lambda (key . args)
	298	(push 5)))
	299	(push 6)
	300	(throw 'a))
	301	(lambda (key . args)
	302	(push 7)
	303	(throw 'b)
	304	(push 8)))
	305	(push 9))
	306	(lambda (key . args)
	307	(push 10))))
	308
	309	(throw-test "again but with two chained throw handlers"
	310	'(0 1 11 2 13 7 5 4 12 13 7 10)
	311	(catch 'b
	312	(lambda ()
	313	(push 0)
	314	(with-throw-handler 'a
	315	(lambda ()
	316	(push 1)
	317	(with-throw-handler 'a
	318	(lambda ()
	319	(push 11)
	320	(catch 'b
	321	(lambda ()
	322	(push 2)
	323	(throw 'a)
	324	(push 3))
325	(lambda (key . args)
326	(push 4))
327	(lambda (key . args)
328	(push 5)))
329	(push 12)
330	(throw 'a))
331	(lambda (key . args)
332	(push 13)))
333	(push 6))
334	(lambda (key . args)
335	(push 7)
336	(throw 'b)))
337	(push 9))
338	(lambda (key . args)
339	(push 10))))
340
341	)
9bc915bb KR	342
9bc915bb KR	343	(with-test-prefix "false-if-exception"
8081c3fb	344
9bc915bb KR	345	(pass-if (false-if-exception #t))
	346	(pass-if (not (false-if-exception #f)))
	347	(pass-if (not (false-if-exception (error "xxx"))))
8081c3fb KR	348
	349	;; Not yet working.
	350	;;
	351	;; (with-test-prefix "in empty environment"
	352	;; ;; an environment with no bindings at all
	353	;; (define empty-environment
	354	;; (make-module 1))
	355	;;
	356	;; (pass-if "#t"
	357	;; (eval `(,false-if-exception #t)
	358	;; empty-environment))
	359	;; (pass-if "#f"
	360	;; (not (eval `(,false-if-exception #f)
	361	;; empty-environment)))
	362	;; (pass-if "exception"
	363	;; (not (eval `(,false-if-exception (,error "xxx"))
	364	;; empty-environment))))
	365	)