Context Navigation

source: project/test-infrastructure/test-infrastructure-base.scm @ 3

Last change on this file since 3 was 3, checked in by felix winkelmann, 15 years ago
udp/test-infrastructure changes; added futures
File size: 89.3 KB

Line
1	;;;; test-infrastructure-hygienic.scm - Test-macros and support code
2	;;;; Copyright (c) Peter K. Keller 2002
3	;;;; Written by Peter K. Keller (psilord@cs.wisc.edu) for use with the CHICKEN
4	;;;; scheme compiler and whoever else wants to use it. Just please include this
5	;;;; little paragraph in any source code derived from the original. This
6	;;;; source code is free to use for any purpose, but no warranty or guarantee
7	;;;; to its stability or robustness is implied in any way. You may not hold me
8	;;;; or anyone else liable for any use of this source code. Please try to keep
9	;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.
10
11	;;;; Modifications Kon Lovett, Oct 15 2005
12
13	(include "test-infrastructure.scm")
14
15	;; Make a destructor object which associates functions and arguments, and
16	;; then applys the functions to the already evaluated arguments when
17	;; asked usually for the side effect of doing so, like removing a file.
18	;; It acts like a queue with the ordering of the functions it calls.
19	;; Any use of it returns a result that should be ignored.
20	;; WARNING, this is a message passing interface, however, the real API to
21	;; the destructor object is function-like. I split it up this way cause I
22	;; this A) consitancy in the API is good, and B) it allows much changing
23	;; of the destructor object message passing interface that is hidden under the
24	;; function API. I want this because I think this object will change a lot in
25	;; the future, and the API separation will make for a good attempt at
26	;; preserving backwards compatibility. Please see the Destructor Object API...
27	(define test:make-destructor
28	(lambda ()
29	(let ((q '()))
30	(lambda (message . args)
31	(cond
32	((equal? message 'atexit)
33	(set! q (append q (list args)))
34	(test:make-ignore-result))
35
36	((equal? message 'activate)
37	(for-each
38	(lambda (promise)
39	;; call all of the functions with args, usually for
40	;; the side effects like removing files and what
41	;; not.
42	(apply (car promise) (cdr promise)))
43	q)
44	(set! q '())
45	(test:make-ignore-result))
46
47	((equal? message 'clear)
48	(set! q '())
49	(test:make-ignore-result))
50
51	((equal? message 'dump)
52	(let loop ((q q))
53	(if (null? q)
54	#t
55	(begin
56	(write (car q))(newline)
57	(loop (cdr q)))))
58	(test:make-ignore-result))
59
60	(else
61	(display "fix destructor message in else case")
62	(newline)
63	(test:make-ignore-result)))))))
64
65	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
66	;; results that are to be ignored(like manipulation of the destructor object
67	;; inside a test case/package) must be stripped out of the evaluated
68	;; test-results
69	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70	(define test:strip-ignored-results
71	(lambda (res)
72	(cond
73	((null? res)
74	'())
75	((ignore-result? (car res))
76	(test:strip-ignored-results (cdr res)))
77	(else
78	(cons (car res) (test:strip-ignored-results (cdr res)))))))
79
80	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
81	;; This next small section of functions deal with creating unique identifiers
82	;; for various types of result objects. This allows us to do elegant html
83	;; generation(the ids are used as anchors) and I'm sure has other useful
84	;; features I have not yet discovered.
85	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86
87	;;;;;;;;;;;;;;;;;;
88	;; test:make-gen-label
89	;; This function accepts a prefix which it then uses to generate serial numbered
90	;; labels.
91	;;;;;;;;;;;;;;;;;;
92	(define test:make-gen-label
93	(lambda (p)
94	(let ((prefix p) (id 0))
95	(lambda ()
96	(let ((oid id))
97	(set! id (+ id 1))
98	(string-append p "_"(number->string oid)))))))
99
100
101	;;;;;;;;;;;;;;;;;;
102	;; This function is a unique label generator so each result object can have
103	;; its own unique serial number for purposes of html generation, or data base
104	;; insertion.
105	;;;;;;;;;;;;;;;;;;
106
107	;; XXX This is a true top level define with state, need to figure out what
108	;; to do about this.... This means you just can't include this file in
109	;; multiple places like a header file anymore.
110	(define test:gen-label (test:make-gen-label "result"))
111
112	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
113	;; These functions create/access typed result lists created by evaluating an
114	;; expect-*, testcase, or package.
115	;; In addition to each type of result, there are predicates
116	;; and accessor functions.
117	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
118
119	;;;;;;;;;;;;;;;;;;
120	;; make a result type the is "ignored". This takes care of things like
121	;; using the destructor object in a sequence of expectations.
122	;;;;;;;;;;;;;;;;;;
123	;; make a result type that is just plainly ignored.
124	(define test:make-ignore-result
125	(lambda ()
126	(list 'ignore-result #t)))
127
128	;; should I ignore something? (destructor or side-effect calls)
129	(define ignore-result?
130	(lambda (l)
131	(and (list? l) (equal? 'ignore-result (car l)))))
132
133	;;;;;;;;;;;;;;;;;;
134	;; a simple function to make a warning list that has a #t in the car position
135	;; if a warning is present, and the warning in the cdr position, or a #f in the
136	;; car position, and an empty string in the cdr position, of no warning is
137	;; needed. A warning is always encapsulated into a result type, and is not
138	;; in and of itself a result type.
139	;;;;;;;;;;;;;;;;;;
140	(define test:make-warning
141	(lambda args
142	(if (and (not (null? args)) (not (zero? (length args))))
143	`(warning #t ,@args)
144	(list 'warning #f '()))))
145
146	;; normal predicate
147	(define test:warning?
148	(lambda (res)
149	(cond
150	((and (list? res) (equal? 'warning (list-ref res 0)))
151	#t)
152	(else
153	#f))))
154
155	;; get the kind of the test case
156	(define test:warning-kind-ref
157	(lambda (res)
158	(if (test:warning? res)
159	(list-ref res 0)
160	'not-a-warning))) ;; XXX Hmm....
161
162	;; is the warning active?
163	(define test:warning-active?
164	(lambda (res)
165	(if (test:warning? res)
166	(list-ref res 1)
167	'not-a-warning))) ;; XXX Hmm....
168
169	;; return the warning user supplied object/message
170	(define test:warning-message-ref
171	(lambda (res)
172	(if (test:warning? res)
173	(list-ref res 2)
174	'not-a-warning))) ;; XXX Hmm....
175
176	;;;;;;;;;;;;;;;;;;
177	;; make-test-case-result
178	;; This function creates a result for an test-case that encapsulates
179	;; many expectation functions. Also included are the accessor
180	;; functions to various elements in the result.
181	;;;;;;;;;;;;;;;;;;
182	(define test:make-test-case-result
183	(lambda (bool message expect-list . warning)
184	(if (not (zero? (length warning)))
185	(list 'test-case-result bool message expect-list
186	(apply test:make-warning warning) (test:gen-label))
187	(list 'test-case-result bool message expect-list
188	(test:make-warning) (test:gen-label)))))
189
190
191	;; normal predicate
192	(define test-case-result?
193	(lambda (res)
194	(cond
195	((and (list? res) (equal? 'test-case-result (list-ref res 0)))
196	#t)
197	(else
198	#f))))
199
200	;; get the kind of the test case
201	(define test-case-result-kind-ref
202	(lambda (res)
203	(if (test-case-result? res)
204	(list-ref res 0)
205	'not-a-test-case-result))) ;; XXX Hmm....
206
207	;; get the result of the test case
208	(define test-case-result-result-ref
209	(lambda (res)
210	(if (test-case-result? res)
211	(list-ref res 1)
212	'not-a-test-case-result))) ;; XXX Hmm....
213
214	;; get the expectations of the test case
215	(define test-case-result-message-ref
216	(lambda (res)
217	(if (test-case-result? res)
218	(list-ref res 2)
219	'not-a-test-case-result))) ;; XXX Hmm....
220
221	;; get the expectations of the test case
222	(define test-case-result-expectations-ref
223	(lambda (res)
224	(if (test-case-result? res)
225	(list-ref res 3)
226	'not-a-test-case-result))) ;; XXX Hmm....
227
228	;; if a warning has been set on this node, return #t
229	(define test-case-result-warning?
230	(lambda (res)
231	(if (test-case-result? res)
232	(test:warning-active? (list-ref res 4))
233	'not-a-test-case-result))) ;; XXX Hmm....
234
235	;; get the warning object, or the default if none.
236	(define test-case-result-warning-ref
237	(lambda (res)
238	(if (test-case-result? res)
239	(test:warning-message-ref (list-ref res 4))
240	'not-a-test-case-result))) ;; XXX Hmm....
241
242	;; get unique serial number associated with this result object.
243	(define test-case-result-id-ref
244	(lambda (res)
245	(if (test-case-result? res)
246	(list-ref res 5)
247	'not-a-test-case-result))) ;; XXX Hmm....
248
249	;;;;;;;;;;;;;;;;;;
250	;; make-test-package-result
251	;; This function creates a result for an test-package that encapsulates
252	;; many test-case functions. Also included are the accessor
253	;; functions to various elements in the result.
254	;;;;;;;;;;;;;;;;;;
255	(define test:make-test-package-result
256	(lambda (bool message *-result-list . warning)
257	(if (not (zero? (length warning)))
258	(list 'test-package-result bool message *-result-list
259	(apply test:make-warning warning) (test:gen-label))
260	(list 'test-package-result bool message *-result-list
261	(test:make-warning) (test:gen-label)))))
262
263	;; normal predicate
264	(define test-package-result?
265	(lambda (res)
266	(cond
267	((and (list? res) (equal? 'test-package-result (list-ref res 0)))
268	#t)
269	(else
270	#f))))
271
272	;; get the kind of the test package
273	(define test-package-result-kind-ref
274	(lambda (res)
275	(if (test-package-result? res)
276	(list-ref res 0)
277	'not-a-test-package-result))) ;; XXX Hmm....
278
279	;; get the result of the test package
280	(define test-package-result-result-ref
281	(lambda (res)
282	(if (test-package-result? res)
283	(list-ref res 1)
284	'not-a-test-package-result))) ;; XXX Hmm....
285
286
287	;; get the message of the test package
288	(define test-package-result-message-ref
289	(lambda (res)
290	(if (test-package-result? res)
291	(list-ref res 2)
292	'not-a-test-package-result))) ;; XXX Hmm....
293
294	;; get the expectations of the test package
295	(define test-package-result-exps-ref
296	(lambda (res)
297	(if (test-package-result? res)
298	(list-ref res 3)
299	'not-a-package-case-result))) ;; XXX Hmm....
300
301	;; if a warning has been set on this node, return #t
302	(define test-package-result-warning?
303	(lambda (res)
304	(if (test-package-result? res)
305	(test:warning-active? (list-ref res 4))
306	'not-a-test-package-result))) ;; XXX Hmm....
307
308	;; get the warning object, or the default if none.
309	(define test-package-result-warning-ref
310	(lambda (res)
311	(if (test-package-result? res)
312	(test:warning-message-ref (list-ref res 4))
313	'not-a-test-package-result))) ;; XXX Hmm....
314
315	;; get serial number of the test package
316	(define test-package-result-id-ref
317	(lambda (res)
318	(if (test-package-result? res)
319	(list-ref res 5)
320	'not-a-package-case-result))) ;; XXX Hmm....
321
322	;;;;;;;;;;;;;;;;;;
323	;; test-case-clause-result?
324	;; Is the value any kind of result, except test-package or test-case?
325	;;;;;;;;;;;;;;;;;;
326	(define (test:test-case-clause-result? v)
327	(or
328	;; XXX There might be a better way to do this check for
329	;; truth. I don't like this use of type checking functions
330	;; here... It causes you to modify this when you add a new
331	;; expectation type.
332	(and (expect-result? v)
333	(equal? #t
334	(expect-result-result-ref v)))
335	(and (expect-equivalence-result? v)
336	(equal? #t
337	(expect-equivalence-result-result-ref v)))
338	(and (expect-tolerance-result? v)
339	(equal? #t
340	(expect-tolerance-result-result-ref v)))
341
342	;; assume ignored results are true for this macro so you
343	;; can keep evaluating.
344	(ignore-result? v)
345
346	;; assume skipped results are true for this macro so you
347	;; can keep evaluating.
348	(skip-result? v)
349
350	;; assume todo results are true for this macro so you
351	;; can keep evaluating.
352	(todo-result? v)
353
354	;; assume gloss results are true for this macro so you
355	;; can keep evaluating.
356	(gloss-result? v)))
357
358	;;;;;;;;;;;;;;;;;;
359	;;make-unexpected-exception-result
360	;;;;;;;;;;;;;;;;;;
361	(define (test:make-unexpected-exception-result curr-clause the-exception)
362	(test:make-expect-result #f "UNKNOWN" "Unexpected Exception" curr-clause the-exception))
363
364
365	;;;;;;;;;;;;;;;;;;
366	;; make-expect-result
367	;; This function creates a result list for an expectation that just
368	;; manipulates a single expression only. Also included are the accessor
369	;; functions to various elements in the result.
370	;;;;;;;;;;;;;;;;;;
371	(define test:make-expect-result
372	(lambda (result specifics message unevaled evaled . warning)
373	(if (not (zero? (length warning)))
374	(list 'expect-result result specifics message unevaled evaled
375	(apply test:make-warning warning) (test:gen-label))
376	(list 'expect-result result specifics message unevaled evaled
377	(test:make-warning) (test:gen-label)))))
378
379	;; normal predicate
380	(define expect-result?
381	(lambda (res)
382	(cond
383	((and (list? res) (equal? 'expect-result (list-ref res 0)))
384	#t)
385	(else
386	#f))))
387
388	;; get the kind of exepctation
389	(define expect-result-kind-ref
390	(lambda (res)
391	(if (expect-result? res)
392	(list-ref res 0)
393	'not-an-expect-result))) ;; XXX Hmm....
394
395	;; get the result of the expectation
396	(define expect-result-result-ref
397	(lambda (res)
398	(if (expect-result? res)
399	(list-ref res 1)
400	'not-an-expect-result))) ;; XXX Hmm....
401
402	;; get the specifics of expectation
403	(define expect-result-specific-ref
404	(lambda (res)
405	(if (expect-result? res)
406	(list-ref res 2)
407	'not-an-expect-result))) ;; XXX Hmm....
408
409	;; get the user supplied message
410	(define expect-result-message-ref
411	(lambda (res)
412	(if (expect-result? res)
413	(list-ref res 3)
414	'not-an-expect-result))) ;; XXX Hmm....
415
416	;; get the user supplied unevaluated expression
417	(define expect-result-unevaled-ref
418	(lambda (res)
419	(if (expect-result? res)
420	(list-ref res 4)
421	'not-an-expect-result))) ;; XXX Hmm....
422
423	;; get the user supplied evaluated expression
424	(define expect-result-evaled-ref
425	(lambda (res)
426	(if (expect-result? res)
427	(list-ref res 5)
428	'not-an-expect-result))) ;; XXX Hmm....
429
430	;; if a warning has been set on this node, return #t
431	(define expect-result-warning?
432	(lambda (res)
433	(if (expect-result? res)
434	(test:warning-active? (list-ref res 6))
435	'not-an-expect-result))) ;; XXX Hmm....
436
437	;; get the warning object, or the default if none.
438	(define expect-result-warning-ref
439	(lambda (res)
440	(if (expect-result? res)
441	(test:warning-message-ref (list-ref res 6))
442	'not-an-expect-result))) ;; XXX Hmm....
443
444	;; get the unique serial number
445	(define expect-result-id-ref
446	(lambda (res)
447	(if (expect-result? res)
448	(list-ref res 7)
449	'not-an-expect-result))) ;; XXX Hmm....
450
451	;;;;;;;;;;;;;;;;;;
452	;; make-expect-equivalence-result
453	;; This function creates a result for an exception that is comparing two things
454	;; together somehow. It holds an evaled lhs and a unevaled and evaled
455	;; rhs of an equivalence operation.
456	;;;;;;;;;;;;;;;;;;
457	(define test:make-expect-equivalence-result
458	(lambda (result specific message lhs rhs-unevaled rhs-evaled . warning)
459	(if (not (zero? (length warning)))
460	(list 'expect-equivalence-result result specific message
461	lhs rhs-unevaled rhs-evaled (apply test:make-warning warning)
462	(test:gen-label))
463	(list 'expect-equivalence-result result specific message
464	lhs rhs-unevaled rhs-evaled (test:make-warning)
465	(test:gen-label)))))
466
467	;; normal predicate
468	(define expect-equivalence-result?
469	(lambda (res)
470	(cond
471	((and (list? res)
472	(equal? 'expect-equivalence-result (list-ref res 0)))
473	#t)
474	(else
475	#f))))
476
477	;; get the kind of the expectation
478	(define expect-equivalence-result-kind-ref
479	(lambda (res)
480	(if (expect-equivalence-result? res)
481	(list-ref res 0)
482	'not-an-expect-equivalence-result))) ;; XXX Hmm....
483
484	;; get the result of the expectation
485	(define expect-equivalence-result-result-ref
486	(lambda (res)
487	(if (expect-equivalence-result? res)
488	(list-ref res 1)
489	'not-an-expect-equivalence-result))) ;; XXX Hmm....
490
491	;; get the specifics of the expectation
492	(define expect-equivalence-result-specific-ref
493	(lambda (res)
494	(if (expect-equivalence-result? res)
495	(list-ref res 2)
496	'not-an-expect-equivalence-result))) ;; XXX Hmm....
497
498	;; get the user supplied message
499	(define expect-equivalence-result-message-ref
500	(lambda (res)
501	(if (expect-equivalence-result? res)
502	(list-ref res 3)
503	'not-an-expect-equivalence-result))) ;; XXX Hmm....
504
505	;; get the user supplied evaluated lhs
506	(define expect-equivalence-result-lhs-evaled-ref
507	(lambda (res)
508	(if (expect-equivalence-result? res)
509	(list-ref res 4)
510	'not-an-expect-equivalence-result))) ;; XXX Hmm....
511
512	;; get the user supplied unevaluated rhs
513	(define expect-equivalence-result-rhs-unevaled-ref
514	(lambda (res)
515	(if (expect-equivalence-result? res)
516	(list-ref res 5)
517	'not-an-expect-equivalence-result))) ;; XXX Hmm....
518
519	;; get the user supplied evaluated rhs
520	(define expect-equivalence-result-rhs-evaled-ref
521	(lambda (res)
522	(if (expect-equivalence-result? res)
523	(list-ref res 6)
524	'not-an-expect-equivalence-result))) ;; XXX Hmm....
525
526	;; if a warning has been set on this node, return #t
527	(define expect-equivalence-result-warning?
528	(lambda (res)
529	(if (expect-equivalence-result? res)
530	(test:warning-active? (list-ref res 7))
531	'not-an-expect-equivalence-result))) ;; XXX Hmm....
532
533	;; get the warning object, or the default if none.
534	(define expect-equivalence-result-warning-ref
535	(lambda (res)
536	(if (expect-equivalence-result? res)
537	(test:warning-message-ref (list-ref res 7))
538	'not-an-expect-equivalence-result))) ;; XXX Hmm....
539
540	;; get the unique serial number for this result
541	(define expect-equivalence-result-id-ref
542	(lambda (res)
543	(if (expect-equivalence-result? res)
544	(list-ref res 8)
545	'not-an-expect-equivalence-result))) ;; XXX Hmm....
546
547	;;;;;;;;;;;;;;;;;;
548	;; make-expect-tolerance-result
549	;; This function creates a result for an expectation that is comparing two
550	;; numbers together within a tolerance. It holds a message, evaled lhs,
551	;; evaled tolerance, and an unevaled and evaled rhs.
552	;;;;;;;;;;;;;;;;;;
553
554	;; holds an evaled lhs and tolerance and an unevaled and evaled rhs
555	(define test:make-expect-tolerance-result
556	(lambda (result style message lhs tol rhs-unevaled rhs-evaled . warning)
557	(if (not (zero? (length warning)))
558	(list 'expect-tolerance-result result style message
559	lhs tol rhs-unevaled rhs-evaled
560	(apply test:make-warning warning)
561	(test:gen-label))
562	(list 'expect-tolerance-result result style message
563	lhs tol rhs-unevaled rhs-evaled (test:make-warning)
564	(test:gen-label)))))
565
566	;; normal predicate
567	(define expect-tolerance-result?
568	(lambda (res)
569	(cond
570	((and (list? res)
571	(equal? 'expect-tolerance-result (list-ref res 0)))
572	#t)
573	(else
574	#f))))
575
576	;; get the kind of expectation
577	(define expect-tolerance-result-kind-ref
578	(lambda (res)
579	(if (expect-tolerance-result? res)
580	(list-ref res 0)
581	'not-an-expect-tolerance-result))) ;; XXX Hmm....
582
583	;; get the result of the expectation
584	(define expect-tolerance-result-result-ref
585	(lambda (res)
586	(if (expect-tolerance-result? res)
587	(list-ref res 1)
588	'not-an-expect-tolerance-result))) ;; XXX Hmm....
589
590	;; get the specific type of tolerance
591	(define expect-tolerance-result-specific-ref
592	(lambda (res)
593	(if (expect-tolerance-result? res)
594	(list-ref res 2)
595	'not-an-expect-tolerance-result))) ;; XXX Hmm....
596
597	;; get the user supplied message
598	(define expect-tolerance-result-message-ref
599	(lambda (res)
600	(if (expect-tolerance-result? res)
601	(list-ref res 3)
602	'not-an-expect-tolerance-result))) ;; XXX Hmm....
603
604	;; get the user supplied evaluated lhs
605	(define expect-tolerance-result-lhs-evaled-ref
606	(lambda (res)
607	(if (expect-tolerance-result? res)
608	(list-ref res 4)
609	'not-an-expect-tolerance-result))) ;; XXX Hmm....
610
611	;; get the user supplied evaluate lhs tolerance
612	(define expect-tolerance-result-lhs-tol-evaled-ref
613	(lambda (res)
614	(if (expect-tolerance-result? res)
615	(list-ref res 5)
616	'not-an-expect-tolerance-result))) ;; XXX Hmm....
617
618	;; get the user supplied unevaluated rhs
619	(define expect-tolerance-result-rhs-unevaled-ref
620	(lambda (res)
621	(if (expect-tolerance-result? res)
622	(list-ref res 6)
623	'not-an-expect-tolerance-result))) ;; XXX Hmm....
624
625	;; get the user supplied evaluated rhs
626	(define expect-tolerance-result-rhs-evaled-ref
627	(lambda (res)
628	(if (expect-tolerance-result? res)
629	(list-ref res 7)
630	'not-an-expect-tolerance-result))) ;; XXX Hmm....
631
632	;; if a warning has been set on this node, return #t
633	(define expect-tolerance-result-warning?
634	(lambda (res)
635	(if (expect-tolerance-result? res)
636	(test:warning-active? (list-ref res 8))
637	'not-an-expect-tolerance-result))) ;; XXX Hmm....
638
639	;; get the warning object, or the default if none.
640	(define expect-tolerance-result-warning-ref
641	(lambda (res)
642	(if (expect-tolerance-result? res)
643	(test:warning-message-ref (list-ref res 8))
644	'not-an-expect-tolerance-result))) ;; XXX Hmm....
645
646	;; get the unique serial number for this result
647	(define expect-tolerance-result-id-ref
648	(lambda (res)
649	(if (expect-tolerance-result? res)
650	(list-ref res 9)
651	'not-an-expect-tolerance-result))) ;; XXX Hmm....
652
653	;;;;;;;;;;;;;;;;;;
654	;; make-terminate-result
655	;; This function creates a result for when an escape procedure gets
656	;; called in a test case or package.
657	;;;;;;;;;;;;;;;;;;
658	(define test:make-terminate-result
659	(lambda (result scope container message)
660	(list 'terminate-result result scope container (terminate-message-ref
661	message) (test:gen-label))))
662
663	;; these next THREE functions are what a user calls in a test case to exit
664	;; a test forcibly. Once this happens, this little list that is made is
665	;; converted into a true termination-result type in the test-case or
666	;; test-package. I'm sorry it had to be split this way...
667	;;;;;;;;;;;;;;;;;;;;
668	;; this is the user called call/cc activation wrapper, call this when you
669	;; want to terminate the computation at the efunc continuation level in
670	;; some test. It allows passing of a message-like object to describe what
671	;; happened and why the terminator was called.
672	;;;;;;;;;;;;;;;;;;;;
673	(define terminate
674	(lambda (efunc message)
675	(efunc (list 'user-termination message))))
676
677	;; simple check for the user termination used internally
678	(define terminate?
679	(lambda (res)
680	(cond
681	((and (list? res)
682	(equal? 'user-termination (list-ref res 0)))
683	#t)
684	(else
685	#f))))
686
687	;; grab the message out of the user supplied termiante event
688	(define terminate-message-ref
689	(lambda (res)
690	(if (terminate? res)
691	(list-ref res 1)
692	'not-a-user-termination))) ;; XXX Hmm....
693
694	;; back to the terminate result code....
695
696	;; normal predicate
697	(define terminate-result?
698	(lambda (res)
699	(cond
700	((and (list? res)
701	(equal? 'terminate-result (list-ref res 0)))
702	#t)
703	(else
704	#f))))
705
706	;; retrive the (internal type) kind of the termination result
707	(define terminate-result-kind-ref
708	(lambda (res)
709	(if (terminate-result? res)
710	(list-ref res 0)
711	'not-a-terminate-result))) ;; XXX Hmm....
712
713	;; retrieve the "result" of the termination XXX hard set to #f currently...
714	(define terminate-result-result-ref
715	(lambda (res)
716	(if (terminate-result? res)
717	(list-ref res 1)
718	'not-a-terminate-result))) ;; XXX Hmm....
719
720	;; retrive the scope of the termination type, this is the associated
721	;; descriptive message the user supplies with the test-case or test-package
722	(define terminate-result-scope-ref
723	(lambda (res)
724	(if (terminate-result? res)
725	(list-ref res 2)
726	'not-a-terminate-result))) ;; XXX Hmm....
727
728	;; retrive the container of the termination type, this will be things like
729	;; 'test-case or 'test-package, basically the container the terminate
730	;; occured in.
731	(define terminate-result-container-ref
732	(lambda (res)
733	(if (terminate-result? res)
734	(list-ref res 3)
735	'not-a-terminate-result))) ;; XXX Hmm....
736
737	;; retrive the user supplied message from the terminate event
738	(define terminate-result-message-ref
739	(lambda (res)
740	(if (terminate-result? res)
741	(list-ref res 4)
742	'not-a-terminate-result))) ;; XXX Hmm....
743
744	;; retrive the unique serial number of the termination
745	(define terminate-result-id-ref
746	(lambda (res)
747	(if (terminate-result? res)
748	(list-ref res 5)
749	'not-a-terminate-result))) ;; XXX Hmm....
750
751	;;;;;;;;;;;;;;;;;;
752	;; todo-result
753	;; This result type makes it know that something still has to be implemented
754	;; or done. It is seperate from the gloss result so you can count up the
755	;; number of todos you have, or do other things based on noticing them.
756	;;;;;;;;;;;;;;;;;;
757	(define test:make-todo-result
758	(lambda (message . warning)
759	(if (not (zero? (length warning)))
760	(list 'todo-result message (apply test:make-warning warning)
761	(test:gen-label))
762	(list 'todo-result message (test:make-warning)
763	(test:gen-label)))))
764
765	;; normal predicate
766	(define todo-result?
767	(lambda (res)
768	(cond
769	((and (list? res)
770	(equal? 'todo-result (list-ref res 0)))
771	#t)
772	(else
773	#f))))
774
775	;; retrive the user supplied message from the todo event
776	(define todo-result-message-ref
777	(lambda (res)
778	(if (todo-result? res)
779	(list-ref res 1)
780	'not-a-todo-result))) ;; XXX Hmm....
781
782	;; if a warning has been set on this node, return #t
783	(define todo-result-warning?
784	(lambda (res)
785	(if (todo-result? res)
786	(test:warning-active? (list-ref res 2))
787	'not-a-todo-result))) ;; XXX Hmm....
788
789	;; get the warning object or the default if none.
790	(define todo-result-warning-ref
791	(lambda (res)
792	(if (todo-result? res)
793	(test:warning-message-ref (list-ref res 2))
794	'not-a-todo-result))) ;; XXX Hmm....
795
796	;; retrive the unique serial number for this result
797	(define todo-result-id-ref
798	(lambda (res)
799	(if (todo-result? res)
800	(list-ref res 3)
801	'not-a-todo-result))) ;; XXX Hmm....
802
803	;;;;;;;;;;;;;;;;;;
804	;; gloss-result
805	;; This is a result type of pure description that the user can insert into
806	;; a test package or a test case. Usually used for messages about the tests
807	;; being done. This result type usually has no value other than to be printed
808	;; out in the output so someone can read it.
809	;;;;;;;;;;;;;;;;;;
810	(define test:make-gloss-result
811	(lambda (message . warning)
812	(if (not (zero? (length warning)))
813	(list 'gloss-result message (apply test:make-warning warning)
814	(test:gen-label))
815	(list 'gloss-result message (test:make-warning)
816	(test:gen-label)))))
817
818	;; normal predicate
819	(define gloss-result?
820	(lambda (res)
821	(cond
822	((and (list? res)
823	(equal? 'gloss-result (list-ref res 0)))
824	#t)
825	(else
826	#f))))
827
828	;; retrive the user supplied message from the gloss event
829	(define gloss-result-message-ref
830	(lambda (res)
831	(if (gloss-result? res)
832	(list-ref res 1)
833	'not-a-gloss-result))) ;; XXX Hmm....
834
835	;; if a warning has been set on this node, return #t
836	(define gloss-result-warning?
837	(lambda (res)
838	(if (gloss-result? res)
839	(test:warning-active? (list-ref res 2))
840	'not-a-gloss-result))) ;; XXX Hmm....
841
842	;; get the warning object or the default if none.
843	(define gloss-result-warning-ref
844	(lambda (res)
845	(if (gloss-result? res)
846	(test:warning-message-ref (list-ref res 2))
847	'not-a-gloss-result))) ;; XXX Hmm....
848
849	;; retrive the unique serial number for this result
850	(define gloss-result-id-ref
851	(lambda (res)
852	(if (gloss-result? res)
853	(list-ref res 3)
854	'not-a-gloss-result))) ;; XXX Hmm....
855
856	;;;;;;;;;;;;;;;;;;
857	;; skip-result
858	;; This result type makes it known that something has been skipped
859	;; It is seperate from the gloss result so you can count up the
860	;; number of skips you have, or do other things based on noticing them.
861	;;;;;;;;;;;;;;;;;;
862	(define test:make-skip-result
863	(lambda (message . warning)
864	(if (not (zero? (length warning)))
865	(list 'skip-result message (apply test:make-warning warning)
866	(test:gen-label))
867	(list 'skip-result message (test:make-warning)
868	(test:gen-label)))))
869
870	;; normal predicate
871	(define skip-result?
872	(lambda (res)
873	(cond
874	((and (list? res)
875	(equal? 'skip-result (list-ref res 0)))
876	#t)
877	(else
878	#f))))
879
880	;; retrive the user supplied message from the skip event
881	(define skip-result-message-ref
882	(lambda (res)
883	(if (skip-result? res)
884	(list-ref res 1)
885	'not-a-skip-result))) ;; XXX Hmm....
886
887	;; if a warning has been set on this node, return #t
888	(define skip-result-warning?
889	(lambda (res)
890	(if (skip-result? res)
891	(test:warning-active? (list-ref res 2))
892	'not-a-skip-result))) ;; XXX Hmm....
893
894	;; get the warning object or the default if none.
895	(define skip-result-warning-ref
896	(lambda (res)
897	(if (skip-result? res)
898	(test:warning-message-ref (list-ref res 2))
899	'not-a-skip-result))) ;; XXX Hmm....
900
901	;; retrive the unique serial number for this result
902	(define skip-result-id-ref
903	(lambda (res)
904	(if (skip-result? res)
905	(list-ref res 3)
906	'not-a-skip-result))) ;; XXX Hmm....
907
908	;;;;;;;;;;;;;;;;;;
909	;; Destructor Object API
910	;; This is a function API for the message-passing style destructor object.
911	;; The impetus to this is I think in the future this lower-level API will
912	;; change a lot, and by separating the API to it to a high and low level
913	;; API, should allow me greater flexibility in maintaining backwards
914	;; compatibility. All destructor calls produce an ignore result the the
915	;; user actually never sees. XXX WARNING XXX It is very hard, if not
916	;; impossible, to typecheck the arguments and be sure that a destructor
917	;; object was actually passed as the first argument. So in the docs for this
918	;; API, it should be said to be VERY CAREFUL with the arguments and make sure
919	;; they are correct.
920	;;;;;;;;;;;;;;;;;;
921
922	(define destructor-atexit!
923	(lambda (dobj . args)
924	(apply dobj `(,'atexit ,@args))))
925
926	(define destructor-activate!
927	(lambda (dobj . args)
928	(apply dobj `(,'activate ,@args))))
929
930	(define destructor-clear!
931	(lambda (dobj . args)
932	(apply dobj `(,'clear ,@args))))
933
934	(define destructor-dump
935	(lambda (dobj . args)
936	(apply dobj `(,'dump ,@args))))
937
938	;;;;;;;;;;;;;;;;;;
939	;; check to see if something is a typed node of any kind generated by a
940	;; expectation, test-case, or test-package
941	;;;;;;;;;;;;;;;;;;
942	(define *-result?
943	(lambda (thingy)
944	(or (skip-result? thingy)
945	(todo-result? thingy)
946	(gloss-result? thingy)
947	(terminate-result? thingy)
948	(expect-result? thingy)
949	(expect-equivalence-result? thingy)
950	(expect-tolerance-result? thingy)
951	(test-case-result? thingy)
952	(test-package-result? thingy))))
953
954	;;;;;;;;;;;;;;;;;;
955	;; grab out the result value of any correctly typed quantity without caring
956	;; what it is.
957	;;;;;;;;;;;;;;;;;;
958	(define *-result-ref
959	(lambda (thingy)
960	(cond
961	((skip-result? thingy) ;; just ignore this and assume truth
962	#t)
963	((gloss-result? thingy) ;; just ignore this and assume truth
964	#t)
965	((todo-result? thingy) ;; just ignore this and assume truth
966	#t)
967	((terminate-result? thingy)
968	(terminate-result-result-ref thingy))
969	((expect-result? thingy)
970	(expect-result-result-ref thingy))
971	((expect-equivalence-result? thingy)
972	(expect-equivalence-result-result-ref thingy))
973	((expect-tolerance-result? thingy)
974	(expect-tolerance-result-result-ref thingy))
975	((test-case-result? thingy)
976	(test-case-result-result-ref thingy))
977	((test-package-result? thingy)
978	(test-package-result-result-ref thingy))
979	((terminate-result? thingy)
980	(terminate-result-result-ref thingy))
981	(else
982	(display "Error! *-result-ref not passed a result type")
983	(newline)
984	#f))))
985
986	;;;;;;;;;;;;;;;;;;
987	;; return true if a warning in the result object exists, for result objects
988	;; that do not contain a warning, return #f
989	;;;;;;;;;;;;;;;;;;
990	(define *-warning?
991	(lambda (thingy)
992	(cond
993	((skip-result? thingy)
994	(skip-result-warning? thingy))
995	((gloss-result? thingy)
996	(gloss-result-warning? thingy))
997	((todo-result? thingy)
998	(todo-result-warning? thingy))
999	((terminate-result? thingy) ;; termination objs do not have warnings
1000	#f)
1001	((expect-result? thingy)
1002	(expect-result-warning? thingy))
1003	((expect-equivalence-result? thingy)
1004	(expect-equivalence-result-warning? thingy))
1005	((expect-tolerance-result? thingy)
1006	(expect-tolerance-result-warning? thingy))
1007	((test-case-result? thingy)
1008	(test-case-result-warning? thingy))
1009	((test-package-result? thingy)
1010	(test-package-result-warning? thingy))
1011	(else
1012	(display "Error! *-warning? not passed a result type")
1013	(newline)
1014	#f))))
1015
1016	;;;;;;;;;;;;;;;;;;
1017	;; see if a list of generic results in a package are all true, this does not
1018	;; recurse down any constructed tree of results, it just looks at the roots
1019	;;;;;;;;;;;;;;;;;;
1020	(define all-testpackage-results-true?
1021	(lambda (rlist)
1022	(letrec ((recurse
1023	(lambda (count rlist)
1024	(cond
1025	((and (null? rlist) (not (zero? count)))
1026	#t)
1027	((and (null? rlist) (zero? count))
1028	#f)
1029	((equal? #t (*-result-ref (car rlist)))
1030	(recurse (+ count 1) (cdr rlist)))
1031	(else
1032	#f)))))
1033	(recurse 0 rlist))))
1034
1035
1036	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1037	;; Here are some functions to walk result trees or lists and determine useful
1038	;; things about them
1039	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1040
1041	;; See if a list of various expectation results are all true or not
1042	(define all-testcase-expectations-true?
1043	(lambda (el)
1044	(letrec ((check-expectations
1045	(lambda (count el)
1046	(cond
1047	;; if the list is passed in empty, then no, they didn't pass
1048	((and (null? el) (zero? count))
1049	#f)
1050
1051	;; if I counted more than one thing, and then hit the empty
1052	;; list, then all of them were true
1053	((and (null? el) (not (zero? count)))
1054	#t)
1055
1056	;; check the various kinds of expectation results.
1057	((and (expect-result? (car el))
1058	(equal? #t (expect-result-result-ref (car el))))
1059	(check-expectations (+ count 1) (cdr el)))
1060
1061	((and (expect-equivalence-result? (car el))
1062	(equal? #t (expect-equivalence-result-result-ref (car el))))
1063	(check-expectations (+ count 1) (cdr el)))
1064
1065	((and (expect-tolerance-result? (car el))
1066	(equal? #t (expect-tolerance-result-result-ref (car el))))
1067	(check-expectations (+ count 1) (cdr el)))
1068
1069	((skip-result? (car el))
1070	;; just consider this true since it is supposed to be
1071	;; transparent to this function and holds no value other
1072	;; than the message it carries.
1073	(check-expectations (+ count 1) (cdr el)))
1074
1075	((gloss-result? (car el))
1076	;; just consider this true since it is supposed to be
1077	;; transparent to this function and holds no value other
1078	;; than the message it carries.
1079	(check-expectations (+ count 1) (cdr el)))
1080
1081	((todo-result? (car el))
1082	;; just consider this true since it is supposed to be
1083	;; transparent to this function and holds no value other
1084	;; than the message it carries.
1085	(check-expectations (+ count 1) (cdr el)))
1086
1087	;; XXX Hmm.... I don't think this should be here...
1088	;; XXX Hmm... figure why I wrote the above comment. I forgot.
1089	((and (terminate-result? (car el))
1090	(equal? #t (terminate-result-result-ref (car el))))
1091	(check-expectations (+ count 1) (cdr el)))
1092
1093	;; if something wasn't true, then stop
1094	(else
1095	#f)))))
1096	(check-expectations 0 el))))
1097
1098
1099
1100	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1101	;; Here is the big section that contains all of the various expect-* functions
1102	;; for anything you might need.
1103	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1104
1105	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1106	;; expect-zero: Expect a value that will be exactly zero
1107	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1108	(define test:_expect-zero
1109	(lambda (msg val)
1110	(zero? val)))
1111
1112
1113
1114	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1115	;; expect-nonzero: Expect a value to be non-zero
1116	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1117	(define test:_expect-nonzero
1118	(lambda (msg val)
1119	(not (zero? val))))
1120
1121
1122	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1123	;; expect-true: Expect a value to be #t
1124	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1125	(define test:_expect-true
1126	(lambda (msg val)
1127	(equal? #t val)))
1128
1129
1130	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1131	;; expect-false: Expect a value to be #f
1132	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1133	(define test:_expect-false
1134	(lambda (msg val)
1135	(equal? #f val)))
1136
1137	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1138	;; expect-eq: Expect the eq? relation to hold between val and arg
1139	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1140	(define test:_expect-eq
1141	(lambda (msg val arg)
1142	(eq? val arg)))
1143
1144
1145	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1146	;; expect-eqv: Expect the eqv? relation to hold between val and arg
1147	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1148	(define test:_expect-eqv
1149	(lambda (msg val arg)
1150	(eqv? val arg)))
1151
1152	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1153	;; expect-equal: Expect the equal? relation to hold between val and arg
1154	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1155	(define test:_expect-equal
1156	(lambda (msg val arg)
1157	(equal? val arg)))
1158
1159
1160	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1161	;; expect-near: Expect a value within a certain tolerance
1162	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1163	(define test:_expect-near
1164	(lambda (msg val tol arg)
1165	(< (abs (- val arg)) tol)))
1166
1167
1168	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1169	;; expect-positive: Expect a number to be positive
1170	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1171	(define test:_expect-positive
1172	(lambda (msg val)
1173	(> val 0)))
1174
1175
1176	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1177	;; expect-negative: Expect a number to be negative.
1178	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1179	(define test:_expect-negative
1180	(lambda (msg val)
1181	(< val 0)))
1182
1183	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1184	;; expect-not-false: Expect a non-false result.
1185	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1186	(define (test:_expect-not-false msg val)
1187	(not (not val)))
1188
1189
1190	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1191	;; expect-values: Expect a multi-valued result.
1192	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1193	(define (test:_expect-values msg val arg)
1194	(val arg))
1195
1196
1197	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1198	;; expect-values support
1199	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1200	(define (test:_values-test msg val arg test)
1201	(and (eq? (length val) (length arg))
1202	(andmap (lambda (a b) (test a b)) val args)))
1203
1204
1205	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1206	;; expect-values-eq: Expect a multi-valued result.
1207	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1208	(define (test:_expect-values-eq msg val arg)
1209	((cut test:_values-test <> <> <> eq?) msg val arg))
1210
1211
1212	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1213	;; expect-values-eqv: Expect a multi-valued result.
1214	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1215	(define (test:_expect-values-eqv msg val arg)
1216	((cut test:_values-test <> <> <> eqv?) msg val arg))
1217
1218
1219	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1220	;; expect-values-equal: Expect a multi-valued result.
1221	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1222	(define (test:_expect-values-equal msg val arg)
1223	((cut test:_values-test <> <> <> equal?) msg val arg))
1224
1225
1226	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1227	;; expect-exception support.
1228	;; (see test:gen-exception-property-test)
1229	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1230	#;(define (test:has-condition-property pred exp)
1231	; assumes the only exception will be from a missing property
1232	(and (condition-case (pred exp) [() #f]) (pred exp)))
1233
1234
1235	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1236	;; expect-exception: Expect an exception.
1237	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1238	(define (test:_expect-exception msg exn val caught)
1239	(and caught val))
1240
1241	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1242	;; Output analysis API functions. These functions take a result tree and
1243	;; construct a "statistics" object which you can use to figure out how
1244	;; many passed/failed packages, cases, and expectations their were. Plus
1245	;; it sums how many warnings in each catagory, todos, and skips there were.
1246	;; It returns a black box object that you use other API calls to pick apart.
1247	;; NOTE: This function expects a a result tree rooted in a single package.
1248	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1249
1250
1251	;;;;;;;;;;;;;;;;;;
1252	;; test:make-statistics
1253	;; This function places the arguments passed to it into a black box statistics
1254	;; object which is then returned.
1255	;;;;;;;;;;;;;;;;;;
1256	(define test:stat-make-statistics
1257	(lambda ()
1258	;; I care about 33 statistics, they are initialized to zero
1259	;; 0 - 32 indexes
1260	(make-vector 33 0)))
1261
1262	;;; XXX Ug, is there a better way to do this?
1263
1264	;; stat-packages
1265	;; The number of test packages in a result tree
1266	(test:gen-stat-API-func set stat-packages-set! 0)
1267	(test:gen-stat-API-func incr stat-packages-incr! 0)
1268	(test:gen-stat-API-func decr stat-packages-decr! 0)
1269	(test:gen-stat-API-func ref stat-packages-ref 0)
1270
1271	;; stat-package-warnings
1272	;; The number of warnings from all of the test packages in a result tree
1273	(test:gen-stat-API-func set stat-package-warnings-set! 1)
1274	(test:gen-stat-API-func incr stat-packages-warnings-incr! 1)
1275	(test:gen-stat-API-func decr stat-package-warnings-decr! 1)
1276	(test:gen-stat-API-func ref stat-package-warnings-ref 1)
1277
1278	;; stat-packages-passed
1279	;; The number of test packages that are #t
1280	(test:gen-stat-API-func set stat-packages-passed-set! 2)
1281	(test:gen-stat-API-func incr stat-packages-passed-incr! 2)
1282	(test:gen-stat-API-func decr stat-packages-passed-decr! 2)
1283	(test:gen-stat-API-func ref stat-packages-passed-ref 2)
1284
1285	;; stat-packages-failed
1286	;; The number of test packages that are #f
1287	(test:gen-stat-API-func set stat-packages-failed-set! 3)
1288	(test:gen-stat-API-func incr stat-packages-failed-incr! 3)
1289	(test:gen-stat-API-func decr stat-packages-failed-decr! 3)
1290	(test:gen-stat-API-func ref stat-packages-failed-ref 3)
1291
1292	;; stat-packages-terminated
1293	;; The number of test packages that had a termination occur in the result tree
1294	(test:gen-stat-API-func set stat-packages-terminated-set! 4)
1295	(test:gen-stat-API-func incr stat-packages-terminated-incr! 4)
1296	(test:gen-stat-API-func decr stat-packages-terminated-decr! 4)
1297	(test:gen-stat-API-func ref stat-packages-terminated-ref 4)
1298
1299	;; stat-cases
1300	;; The number of test cases in the result tree
1301	(test:gen-stat-API-func set stat-cases-set! 5)
1302	(test:gen-stat-API-func incr stat-cases-incr! 5)
1303	(test:gen-stat-API-func decr stat-cases-decr! 5)
1304	(test:gen-stat-API-func ref stat-cases-ref 5)
1305
1306	;; stat-case-warnings
1307	;; The number of warnings from all of the test cases in a result tree
1308	(test:gen-stat-API-func set stat-case-warnings-set! 6)
1309	(test:gen-stat-API-func incr stat-case-warnings-incr! 6)
1310	(test:gen-stat-API-func decr stat-case-warnings-decr! 6)
1311	(test:gen-stat-API-func ref stat-case-warnings-ref 6)
1312
1313	;; stat-cases-passed
1314	;; The number of test cases that were #t in the result tree
1315	(test:gen-stat-API-func set stat-cases-passed-set! 7)
1316	(test:gen-stat-API-func incr stat-cases-passed-incr! 7)
1317	(test:gen-stat-API-func decr stat-cases-passed-decr! 7)
1318	(test:gen-stat-API-func ref stat-cases-passed-ref 7)
1319
1320	;; stat-cases-failed
1321	;; The number of test cases that were #f in the result tree
1322	(test:gen-stat-API-func set stat-cases-failed-set! 8)
1323	(test:gen-stat-API-func incr stat-cases-failed-incr! 8)
1324	(test:gen-stat-API-func decr stat-cases-failed-decr! 8)
1325	(test:gen-stat-API-func ref stat-cases-failed-ref 8)
1326
1327	;; stat-cases-terminated
1328	;; The number of test cases that had a termination happen in the result tree
1329	(test:gen-stat-API-func set stat-cases-failed-set! 9)
1330	(test:gen-stat-API-func incr stat-cases-failed-incr! 9)
1331	(test:gen-stat-API-func decr stat-cases-failed-decr! 9)
1332	(test:gen-stat-API-func ref stat-cases-failed-ref 9)
1333
1334	;; stat-all-expectations
1335	;; The number of all of the expectaions evaluated in the result tree
1336	(test:gen-stat-API-func set stat-all-expectations-set! 10)
1337	(test:gen-stat-API-func incr stat-all-expectations-incr! 10)
1338	(test:gen-stat-API-func decr stat-all-expectations-decr! 10)
1339	(test:gen-stat-API-func ref stat-all-expectations-ref 10)
1340
1341	;; stat-all-expectation-warnings
1342	;; The number of all the warnings for all of the expectations in the result tree
1343	(test:gen-stat-API-func set stat-all-expectation-warnings-set! 11)
1344	(test:gen-stat-API-func incr stat-all-expectation-warnings-incr! 11)
1345	(test:gen-stat-API-func decr stat-all-expectation-warnings-decr! 11)
1346	(test:gen-stat-API-func ref stat-all-expectation-warnings-ref 11)
1347
1348	;; stat-all-expectations-passed
1349	;; The number of all of the expectations that had passed in the result tree
1350	(test:gen-stat-API-func set stat-all-expectations-passed-set! 12)
1351	(test:gen-stat-API-func incr stat-all-expectations-passed-incr! 12)
1352	(test:gen-stat-API-func decr stat-all-expectations-passed-decr! 12)
1353	(test:gen-stat-API-func ref stat-all-expectations-passed-ref 12)
1354
1355	;; stat-all-expectations-failed
1356	;; The number of all of the expectations that had failed in the result tree
1357	(test:gen-stat-API-func set stat-all-expectations-failed-set! 13)
1358	(test:gen-stat-API-func incr stat-all-expectations-failed-incr! 13)
1359	(test:gen-stat-API-func decr stat-all-expectations-failed-decr! 13)
1360	(test:gen-stat-API-func ref stat-all-expectations-failed-ref 13)
1361
1362	;; stat-single-expectations
1363	;; The number of single style expectations in the result tree
1364	(test:gen-stat-API-func set stat-single-expectations-set! 14)
1365	(test:gen-stat-API-func incr stat-single-expectations-incr! 14)
1366	(test:gen-stat-API-func decr stat-single-expectations-decr! 14)
1367	(test:gen-stat-API-func ref stat-single-expectations-ref 14)
1368
1369	;; stat-single-expectation-warnings
1370	;; The number of single style expectations with warnings in the result tree
1371	(test:gen-stat-API-func set stat-single-expectation-warnings-set! 15)
1372	(test:gen-stat-API-func incr stat-single-expectation-warnings-incr! 15)
1373	(test:gen-stat-API-func decr stat-single-expectation-warnings-decr! 15)
1374	(test:gen-stat-API-func ref stat-single-expectation-warnings-ref 15)
1375
1376	;; stat-single-expectations-passed
1377	;; The number of single style expectations that passed in the result tree
1378	(test:gen-stat-API-func set stat-single-expectations-passed-set! 16)
1379	(test:gen-stat-API-func incr stat-single-expectations-passed-incr! 16)
1380	(test:gen-stat-API-func decr stat-single-expectations-passed-decr! 16)
1381	(test:gen-stat-API-func ref stat-single-expectations-passed-ref 16)
1382
1383	;; stat-single-expectations-failed
1384	;; The number of single style expectations that had failed in the result tree
1385	(test:gen-stat-API-func set stat-single-expectations-failed-set! 17)
1386	(test:gen-stat-API-func incr stat-single-expectations-failed-incr! 17)
1387	(test:gen-stat-API-func decr stat-single-expectations-failed-decr! 17)
1388	(test:gen-stat-API-func ref stat-single-expectations-failed-ref 17)
1389
1390	;; stat-tol-expectations
1391	;; The number of tolerance style expectations in the result tree
1392	(test:gen-stat-API-func set stat-tol-expectations-set! 18)
1393	(test:gen-stat-API-func incr stat-tol-expectations-incr! 18)
1394	(test:gen-stat-API-func decr stat-tol-expectations-decr! 18)
1395	(test:gen-stat-API-func ref stat-tol-expectations-ref 18)
1396
1397	;; stat-tol-expectation-warnings
1398	;; The number of tolerance expectations that had warnings in the tree
1399	(test:gen-stat-API-func set stat-tol-expectation-warnings-set! 19)
1400	(test:gen-stat-API-func incr stat-tol-expectation-warnings-incr! 19)
1401	(test:gen-stat-API-func decr stat-tol-expectation-warnings-decr! 19)
1402	(test:gen-stat-API-func ref stat-tol-expectation-warnings-ref 19)
1403
1404	;; stat-tol-expectations-passed
1405	;; The number of tolerance style expectations that passed in the result tree
1406	(test:gen-stat-API-func set stat-tol-expectations-passed-set! 20)
1407	(test:gen-stat-API-func incr stat-tol-expectations-passed-incr! 20)
1408	(test:gen-stat-API-func decr stat-tol-expectations-passed-decr! 20)
1409	(test:gen-stat-API-func ref stat-tol-expectations-passed-ref 20)
1410
1411	;; stat-tol-expectations-failed
1412	;; The number of tolerance style expectations that failed in the result tree
1413	(test:gen-stat-API-func set stat-tol-expectations-failed-set! 21)
1414	(test:gen-stat-API-func incr stat-tol-expectations-failed-incr! 21)
1415	(test:gen-stat-API-func decr stat-tol-expectations-failed-decr! 21)
1416	(test:gen-stat-API-func ref stat-tol-expectations-failed-ref 21)
1417
1418	;; stat-equiv-expectations
1419	;; The number of equivalence style expectations in the result tree
1420	(test:gen-stat-API-func set stat-equiv-expectations-set! 22)
1421	(test:gen-stat-API-func incr stat-equiv-expectations-incr! 22)
1422	(test:gen-stat-API-func decr stat-equiv-expectations-decr! 22)
1423	(test:gen-stat-API-func ref stat-equiv-expectations-ref 22)
1424
1425	;; stat-equiv-expectation-warnings
1426	;; The number of tolerance expectations that had warnings in the tree
1427	(test:gen-stat-API-func set stat-equiv-expectation-warnings-set! 23)
1428	(test:gen-stat-API-func incr stat-equiv-expectation-warnings-incr! 23)
1429	(test:gen-stat-API-func decr stat-equiv-expectation-warnings-decr! 23)
1430	(test:gen-stat-API-func ref stat-equiv-expectation-warnings-ref 23)
1431
1432	;; stat-equiv-expectations-passed
1433	;; The number of tolerance expectations that failed in the result tree
1434	(test:gen-stat-API-func set stat-equiv-expectations-passed-set! 24)
1435	(test:gen-stat-API-func incr stat-equiv-expectations-passed-incr! 24)
1436	(test:gen-stat-API-func decr stat-equiv-expectations-passed-decr! 24)
1437	(test:gen-stat-API-func ref stat-equiv-expectations-passed-ref 24)
1438
1439	;; stat-equiv-expectations-failed
1440	;; The number of tolerance expectations that failed in the result tree
1441	(test:gen-stat-API-func set stat-equiv-expectations-failed-set! 25)
1442	(test:gen-stat-API-func incr stat-equiv-expectations-failed-incr! 25)
1443	(test:gen-stat-API-func decr stat-equiv-expectations-failed-decr! 25)
1444	(test:gen-stat-API-func ref stat-equiv-expectations-failed-ref 25)
1445
1446	;; stat-todos
1447	;; The number of todos in the result tree
1448	(test:gen-stat-API-func set stat-todos-set! 26)
1449	(test:gen-stat-API-func incr stat-todos-incr! 26)
1450	(test:gen-stat-API-func decr stat-todos-decr! 26)
1451	(test:gen-stat-API-func ref stat-todos-ref 26)
1452
1453	;; stat-todo-warnings
1454	;; The number of todos with warnings in the result tree
1455	(test:gen-stat-API-func set stat-todo-warnings-set! 27)
1456	(test:gen-stat-API-func incr stat-todo-warnings-incr! 27)
1457	(test:gen-stat-API-func decr stat-todo-warnings-decr! 27)
1458	(test:gen-stat-API-func ref stat-todo-warnings-ref 27)
1459
1460	;; stat-skips
1461	;; The number of skips in the result tree
1462	(test:gen-stat-API-func set stat-skips-set! 28)
1463	(test:gen-stat-API-func incr stat-skips-incr! 28)
1464	(test:gen-stat-API-func decr stat-skips-decr! 28)
1465	(test:gen-stat-API-func ref stat-skips-ref 28)
1466
1467	;; stat-skip-warnings
1468	;; The number of skips with warnings in the result tree
1469	(test:gen-stat-API-func set stat-skip-warnings-set! 29)
1470	(test:gen-stat-API-func incr stat-skip-warnings-incr! 29)
1471	(test:gen-stat-API-func decr stat-skip-warnings-decr! 29)
1472	(test:gen-stat-API-func ref stat-skip-warnings-ref 29)
1473
1474	;; stat-glosses
1475	;; The number of glosses in the result tree
1476	(test:gen-stat-API-func set stat-glosses-set! 30)
1477	(test:gen-stat-API-func incr stat-glosses-incr! 30)
1478	(test:gen-stat-API-func decr stat-glosses-decr! 30)
1479	(test:gen-stat-API-func ref stat-glosses-ref 30)
1480
1481	;; stat-gloss-warnings
1482	;; The number of glosses with warnings in the result tree
1483	(test:gen-stat-API-func set stat-gloss-warnings-set! 31)
1484	(test:gen-stat-API-func incr stat-gloss-warnings-incr! 31)
1485	(test:gen-stat-API-func decr stat-gloss-warnings-decr! 31)
1486	(test:gen-stat-API-func ref stat-gloss-warnings-ref 31)
1487
1488	;; stat-terminations
1489	;; The number of terminations in the result tree
1490	(test:gen-stat-API-func set stat-terminations-set! 32)
1491	(test:gen-stat-API-func incr stat-terminations-incr! 32)
1492	(test:gen-stat-API-func decr stat-terminations-decr! 32)
1493	(test:gen-stat-API-func ref stat-terminations-ref 32)
1494
1495
1496	;;;;;;;;;;;;;;;;;;
1497	;; stat-compute-statistics
1498	;; This function walks a result tree and returns a statistics object which you
1499	;; may query with the above API.
1500	;; NOTE: This function expects a result tree rooted in a single test package.
1501	;;;;;;;;;;;;;;;;;;
1502
1503	(define stat-compute-statistics
1504	(lambda (resnode)
1505	(let ((stats (test:stat-make-statistics)))
1506	;; tally walks the result tree and sums up the various catagories of
1507	;; things I care about for each type of result object.
1508	(letrec ((tally
1509	(lambda (resnode)
1510	(cond
1511	;; compute statistics about a package result
1512	((test-package-result? resnode)
1513
1514	;; count the package object
1515	(stat-packages-incr! stats)
1516
1517	;; count the success or failure of it
1518	(if (equal? #t (test-package-result-result-ref resnode))
1519	(stat-packages-passed-incr! stats)
1520	(stat-packages-failed-incr! stats))
1521
1522	;; count the warning if one exists.
1523	(cond
1524	((test-package-result-warning? resnode)
1525	(stat-package-warnings-incr! stats)))
1526
1527	;; now, compute the statistics of everything inside the
1528	;; test package
1529	(for-each
1530	(lambda (node) (tally node))
1531	(test-package-result-exps-ref resnode)))
1532
1533	;; compute statistics about a case result
1534	((test-case-result? resnode)
1535
1536	;; count the case object
1537	(stat-cases-incr! stats)
1538
1539	;; count the success or failure of it
1540	(if (equal? #t (test-case-result-result-ref resnode))
1541	(stat-cases-passed-incr! stats)
1542	(stat-cases-failed-incr! stats))
1543
1544	;; count the warning if one exists.
1545	(cond
1546	((test-case-result-warning? resnode)
1547	(stat-case-warnings-incr! stats)))
1548
1549	;; now, compute the statistics of everything inside the
1550	;; test case
1551	(for-each
1552	(lambda (node) (tally node))
1553	(test-case-result-expectations-ref resnode)))
1554
1555	;; count the statistics about a single styled expectation
1556	((expect-result? resnode)
1557	;; count the expectation generally
1558	(stat-all-expectations-incr! stats)
1559	;; count the expectation specifically
1560	(stat-single-expectations-incr! stats)
1561
1562	;; count if it passed or succeeded
1563	(if (equal? #t (expect-result-result-ref resnode))
1564	(begin
1565	(stat-all-expectations-passed-incr! stats)
1566	(stat-single-expectations-passed-incr! stats))
1567	(begin
1568	(stat-all-expectations-failed-incr! stats)
1569	(stat-single-expectations-failed-incr! stats)))
1570
1571	;; count any warnings
1572	(cond
1573	((expect-result-warning? resnode)
1574	(stat-all-expectation-warnings-incr! stats)
1575	(stat-single-expectation-warnings-incr! stats))))
1576
1577	;; count the statistics about a tolerance styled expectation
1578	((expect-tolerance-result? resnode)
1579	;; count the expectation generally
1580	(stat-all-expectations-incr! stats)
1581	;; count the expectation specifically
1582	(stat-tol-expectations-incr! stats)
1583
1584	;; count if it passed or succeeded
1585	(if (equal? #t (expect-tolerance-result-result-ref resnode))
1586	(begin
1587	(stat-all-expectations-passed-incr! stats)
1588	(stat-tol-expectations-passed-incr! stats))
1589	(begin
1590	(stat-all-expectations-failed-incr! stats)
1591	(stat-tol-expectations-failed-incr! stats)))
1592
1593	;; count any warnings
1594	(cond
1595	((expect-tolerance-result-warning? resnode)
1596	(stat-all-expectation-warnings-incr! stats)
1597	(stat-tol-expectation-warnings-incr! stats))))
1598
1599	;; count the statistics about an equivalence styled
1600	;; expectation
1601	((expect-equivalence-result? resnode)
1602	;; count the expectation generally
1603	(stat-all-expectations-incr! stats)
1604	;; count the expectation specifically
1605	(stat-equiv-expectations-incr! stats)
1606
1607	;; count if it passed or succeeded
1608	(if (equal? #t (expect-equivalence-result-result-ref resnode))
1609	(begin
1610	(stat-all-expectations-passed-incr! stats)
1611	(stat-equiv-expectations-passed-incr! stats))
1612	(begin
1613	(stat-all-expectations-failed-incr! stats)
1614	(stat-equiv-expectations-failed-incr! stats)))
1615
1616	;; count any warnings
1617	(cond
1618	((expect-equivalence-result-warning? resnode)
1619	(stat-all-expectation-warnings-incr! stats)
1620	(stat-equiv-expectation-warnings-incr! stats))))
1621
1622	;; count the terminations and where they happened
1623	((terminate-result? resnode)
1624	;; count it
1625	(stat-terminations-incr! stats)
1626
1627	;; figure out the scope and count it in the right one
1628	(cond
1629	((equal? 'test-case
1630	(temination-result-container-ref resnode))
1631	(stat-cases-terminated-incr! stats))
1632
1633	((equal? 'test-package
1634	(temination-result-container-ref resnode))
1635	(stat-packages-terminated-incr! stats))))
1636
1637
1638
1639	;; even count stuff like glosses and warnings in them
1640	((gloss-result? resnode)
1641	;; count it
1642	(stat-glosses-incr! stats)
1643
1644	;; count any warnings
1645	(cond
1646	((gloss-result-warning? resnode)
1647	(stat-gloss-warnings-incr! stats))))
1648
1649
1650	;; count how many todos there are and warnings
1651	((todo-result? resnode)
1652	;; count it
1653	(stat-todos-incr! stats)
1654
1655	;; count any warnings
1656	(cond
1657	((todo-result-warning? resnode)
1658	(stat-todo-warnings-incr! stats))))
1659
1660	;; count how many skips there are and warnings
1661	((skip-result? resnode)
1662	;; count it
1663	(stat-skips-incr! stats)
1664
1665	;; count any warnings
1666	(cond
1667	((skip-result-warning? resnode)
1668	(stat-skip-warnings-incr! stats))))
1669
1670	;; dump an error if passed something I don't know about.
1671	(else
1672	(printnl "*** Error in compute-result-statistics")
1673	(printnl " Unknown result node!: " resnode))))))
1674
1675	(tally resnode)
1676	stats))))
1677
1678	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1679	;; Output generation functions. These functions take a result tree and emit
1680	;; human readable, html, whatever else you want. Here I've supplied a
1681	;; simple one which just emits human readable output. This is a simple
1682	;; generator which only accepts ONE toplevel result tree.
1683	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1684
1685	;; indent the number of spaces required
1686	(define test:indent
1687	(lambda (spaces)
1688	(let loop ((tpi spaces))
1689	(if (zero? tpi)
1690	#t
1691	(begin
1692	(display " ")
1693	(loop (- tpi 1)))))))
1694
1695
1696	;; define the usually wanted display with multiple arguments and newline at the
1697	;; end.
1698	(define printnl
1699	(lambda args
1700	(for-each (lambda (out) (display out)) args)
1701	(newline)))
1702
1703	;; define the usually wanted display with multiple arguments and no newline at
1704	;; the end.
1705	(define printme
1706	(lambda args
1707	(for-each (lambda (out) (display out)) args)))
1708
1709	;; print something at an indention level
1710	(define printinl
1711	(lambda (indent . args)
1712	(test:indent indent)
1713	(apply printnl args)))
1714
1715	;; print something at an indention level + 2
1716	(define printinl/+2
1717	(lambda (indent . args)
1718	(test:indent (+ indent 2))
1719	(apply printnl args)))
1720
1721	;; print something at an indention level
1722	(define printime
1723	(lambda (indent . args)
1724	(test:indent indent)
1725	(apply printme args)))
1726
1727	;; dump out simple human readable output for a result tree, and return the
1728	;; boolean result of the root.
1729	(define output-human-simple
1730	(lambda (resnode)
1731	(letrec ((xlate
1732	(lambda (indent resnode)
1733
1734	(cond
1735	;; print out a package result
1736	((test-package-result? resnode)
1737
1738	(printinl indent
1739	"Begin Package: " (test-package-result-message-ref resnode))
1740
1741	;; dump out any warnings...
1742	(cond ((test-package-result-warning? resnode)
1743	(printinl indent "WARNING: "
1744	(test-package-result-warning-ref resnode))))
1745
1746	;; process each evaluated object held in the test package
1747	(for-each
1748	(lambda (node) (xlate (+ indent 2) node))
1749	(test-package-result-exps-ref resnode))
1750
1751	(printinl indent
1752	"Result: " (test-package-result-result-ref resnode))
1753	(printinl indent
1754	"End Package: " (test-package-result-message-ref resnode))
1755	(newline))
1756
1757	;; print out a test-case result
1758	((test-case-result? resnode)
1759	(printinl indent
1760	"Begin Test Case: " (test-case-result-message-ref resnode))
1761
1762	;; dump out any warnings...
1763	(cond ((test-case-result-warning? resnode)
1764	(printinl indent "WARNING: "
1765	(test-case-result-warning-ref resnode))))
1766
1767	;; process each expectation result.
1768	(for-each
1769	(lambda (node) (xlate (+ indent 2) node))
1770	(test-case-result-expectations-ref resnode))
1771	(printinl indent "Result: " (test-case-result-result-ref resnode))
1772	(printinl indent
1773	"End Test Case: " (test-case-result-message-ref resnode))
1774	(newline))
1775
1776	;; print out an expect-result
1777	((expect-result? resnode)
1778	(printinl indent
1779	"Begin Expectation: " (expect-result-message-ref resnode))
1780	(printinl indent "Expect " (expect-result-specific-ref resnode))
1781
1782	;; dump out any warnings...
1783	(cond ((expect-result-warning? resnode)
1784	(printinl indent "WARNING: "
1785	(expect-result-warning-ref resnode))))
1786
1787	(printinl/+2 indent "Unevaluated: ")
1788	(printinl/+2 indent (expect-result-unevaled-ref resnode))
1789	(printinl/+2 indent "Evaluated: ")
1790	(printinl/+2 indent (expect-result-evaled-ref resnode))
1791	(printinl indent "Result: " (expect-result-result-ref resnode))
1792	(printinl indent
1793	"End Expectation: " (expect-result-message-ref resnode))
1794	(newline))
1795
1796	;; print out an expect-tolerance-result
1797	((expect-tolerance-result? resnode)
1798	(printinl indent
1799	"Begin Expectation: "
1800	(expect-tolerance-result-message-ref resnode))
1801	(printinl indent "Expect "
1802	(expect-tolerance-result-specific-ref resnode))
1803
1804	;; dump out any warnings...
1805	(cond ((expect-tolerance-result-warning? resnode)
1806	(printinl indent "WARNING: "
1807	(expect-tolerance-result-warning-ref resnode))))
1808
1809	(printinl/+2 indent "Expected Value: ")
1810	(printinl/+2 indent
1811	(expect-tolerance-result-lhs-evaled-ref resnode))
1812	(printinl/+2 indent "Expected Tolerance: ")
1813	(printinl/+2 indent
1814	(expect-tolerance-result-lhs-tol-evaled-ref resnode))
1815	(printinl/+2 indent "Unevaluated: ")
1816	(printinl/+2 indent
1817	(expect-tolerance-result-rhs-unevaled-ref resnode))
1818	(printinl/+2 indent "Evaluated: ")
1819	(printinl/+2 indent
1820	(expect-tolerance-result-rhs-evaled-ref resnode))
1821	(printinl indent "Result: "
1822	(expect-tolerance-result-result-ref resnode))
1823
1824	(printinl indent
1825	"End Expectation: "
1826	(expect-tolerance-result-message-ref resnode))
1827	(newline))
1828
1829	;; print out an expect-equivalence-result
1830	((expect-equivalence-result? resnode)
1831	(printinl indent
1832	"Begin Expectation: "
1833	(expect-equivalence-result-message-ref resnode))
1834	(printinl indent "Expect "
1835	(expect-equivalence-result-specific-ref resnode))
1836
1837	;; dump out any warnings...
1838	(cond ((expect-equivalence-result-warning? resnode)
1839	(printinl indent "WARNING: "
1840	(expect-equivalence-result-warning-ref resnode))))
1841
1842	(printinl/+2 indent "Expected Value: ")
1843	(printinl/+2 indent
1844	(expect-equivalence-result-lhs-evaled-ref resnode))
1845	(printinl/+2 indent "Unevaluated: ")
1846	(printinl/+2 indent
1847	(expect-equivalence-result-rhs-unevaled-ref resnode))
1848	(printinl/+2 indent "Evaluated: ")
1849	(printinl/+2 indent
1850	(expect-equivalence-result-rhs-evaled-ref resnode))
1851	(printinl indent "Result: "
1852	(expect-equivalence-result-result-ref resnode))
1853
1854	(printinl indent
1855	"End Expectation: "
1856	(expect-equivalence-result-message-ref resnode))
1857	(newline))
1858
1859	;; print out a user-invoked termination result
1860	((terminate-result? resnode)
1861	(printinl indent "Begin TERMINATION")
1862	(printinl/+2 indent
1863	"Message: " (terminate-result-message-ref resnode))
1864	(printinl/+2 indent
1865	"Container: " (terminate-result-container-ref resnode))
1866	(printinl/+2 indent
1867	"Scope: " (terminate-result-scope-ref resnode))
1868	(printinl indent
1869	"Result: " (terminate-result-result-ref resnode))
1870	(printinl indent "End TERMINATION")
1871	(newline))
1872
1873	;; print out any gloss message the user might have inserted somewhere.
1874	((gloss-result? resnode)
1875	(printinl indent "GLOSS: " (gloss-result-message-ref resnode))
1876	;; dump out any warnings...
1877	(cond ((gloss-result-warning? resnode)
1878	(printinl indent "WARNING: "
1879	(gloss-result-warning-ref resnode))))
1880	(printinl indent ""))
1881
1882	;; print out any todo message the user might have inserted somewhere.
1883	((todo-result? resnode)
1884	(printinl indent "TODO: " (todo-result-message-ref resnode))
1885	;; dump out any warnings...
1886	(cond ((todo-result-warning? resnode)
1887	(printinl indent "WARNING: "
1888	(todo-result-warning-ref resnode))))
1889	(printinl indent ""))
1890
1891	;; print out any skipped thing the user may have done.
1892	((skip-result? resnode)
1893	(printinl indent "SKIP: " (skip-result-message-ref resnode))
1894	;; dump out any warnings...
1895	(cond ((skip-result-warning? resnode)
1896	(printinl indent "WARNING: "
1897	(skip-result-warning-ref resnode))))
1898	(printinl indent ""))
1899
1900	(else
1901	(printinl indent "*** Error: Unknown result node!: " resnode))))))
1902
1903	;; figure out if I was passed the right stuff, die of not.
1904	(cond
1905	((test-package-result? resnode)
1906	;; spew out the tree
1907	;; start the translation at column zero
1908	(xlate 0 resnode)
1909	(if (equal? #t (test-package-result-result-ref resnode))
1910	(printnl "ALL TESTS SUCCESSFUL!")
1911	(printnl "SOME TESTS FAILED!"))
1912	;; return the toplevel package result to the caller
1913	(test-package-result-result-ref resnode))
1914	(else
1915	(display "You did not pass (output-style-human ...) a valid ")
1916	(display "test package result tree.")
1917	(newline))))))
1918
1919
1920	;; dump out simple html readable output for a result tree, and return the
1921	;; boolean result of the root. This function is very big, mostly because it
1922	;; has some helper functions inside it to do the work, and one big translation
1923	;; function that I didn't want available except to this function.
1924	(define output-html-simple
1925	(lambda (resnode)
1926	(letrec (
1927	;; some html tag creation helpers
1928	(begin-anchor
1929	(lambda (str)
1930	(string-append str "_begin")))
1931	(end-anchor
1932	(lambda (str)
1933	(string-append str "_end")))
1934
1935	;; this function spits out the entire result tree in html with anchor
1936	;; tags, and color coding.
1937	;; XXX Eh, this code could be better written, but I don't want to design
1938	;; and build a whole HTML package just to do it nicely.
1939	(xlate
1940	(lambda (indent resnode)
1941	(cond
1942	;; print out a package result
1943	((test-package-result? resnode)
1944	(printinl indent "<dl>")
1945
1946	(printinl indent "<dt>")
1947	;; print out "Begin Package:" with anchors and links set up nice
1948	(printme
1949	"<a name=\"" (begin-anchor (test-package-result-id-ref resnode))
1950	"\"> "
1951	"<a href=\"#" (end-anchor (test-package-result-id-ref resnode))
1952	"\"> Begin Package: </a> </a> ")
1953
1954	;; print out the message from this package, color coded for
1955	;; success or failure.
1956	(printnl
1957	(if (equal? #t (test-package-result-result-ref resnode))
1958	"<font color=#66cc66> "
1959	"<font color=#cc6666> ")
1960	(test-package-result-message-ref resnode)
1961	" </font>")
1962	(printinl indent "</dt>")
1963
1964	;; dump out any warnings...
1965	(cond ((test-package-result-warning? resnode)
1966	(printinl indent "<dt>")
1967	(printinl indent "<font color=#cccc66>")
1968	(printinl indent "WARNING: "
1969	(test-package-result-warning-ref resnode))
1970	(printinl indent "</font>")
1971	(printinl indent "</dt>")))
1972	(printinl indent "<br>")
1973
1974	;; process each evaluated object held in the test package
1975	(for-each
1976	(lambda (node) (xlate (+ indent 2) node))
1977	(test-package-result-exps-ref resnode))
1978
1979	(printinl indent "<dt>")
1980	;; print out "Result: " with the color of success or failure
1981	(if (equal? #t (test-package-result-result-ref resnode))
1982	(printime indent
1983	"<font color=#66cc66> Result: ")
1984	(printime indent
1985	"<font color=#cc6666> Result: "))
1986
1987	;; now print the actual boolean representing the result
1988	(printnl
1989	(test-package-result-result-ref resnode) " </font>")
1990	(printinl indent "</dt>")
1991
1992	(printinl indent "<dt>")
1993	;; Print the "End Package:" message knowing it is not only the
1994	;; anchor for the bottom of the test package, but also a link to
1995	;; the top of the package.
1996	(printime indent
1997	"<a name=\""
1998	(end-anchor (test-package-result-id-ref resnode))
1999	"\"> "
2000	"<a href=\"#"
2001	(begin-anchor (test-package-result-id-ref resnode))
2002	"\"> End Package: </a> </a>")
2003
2004	;; print out the name of the package colored for success or failure.
2005	(printnl
2006	(if (equal? #t (test-package-result-result-ref resnode))
2007	"<font color=#66cc66> "
2008	"<font color=#cc6666> ")
2009	(test-package-result-message-ref resnode)
2010	" </font>")
2011	(printinl indent "</dt>")
2012
2013	(printinl indent "<br>")
2014	(printinl indent "</dl>"))
2015
2016	;; print out a test-case result
2017	((test-case-result? resnode)
2018	(printinl indent "<dl>")
2019
2020	(printinl indent "<dt>")
2021	;; print out "Begin Test Case:" with anchors and links set up nice
2022	(printme
2023	"<a name=\"" (begin-anchor (test-case-result-id-ref resnode))
2024	"\"> "
2025	"<a href=\"#" (end-anchor (test-case-result-id-ref resnode))
2026	"\"> Begin Test Case: </a> </a> ")
2027
2028	;; print out the message from this package, color coded for
2029	;; success or failure.
2030	(printnl
2031	(if (equal? #t (test-case-result-result-ref resnode))
2032	"<font color=#66cc66> "
2033	"<font color=#cc6666> ")
2034	(test-case-result-message-ref resnode)
2035	" </font>")
2036	(printinl indent "</dt>")
2037
2038
2039	;; dump out any warnings...
2040	(cond ((test-case-result-warning? resnode)
2041	(printinl indent "<dt>")
2042	(printinl indent "<font color=#cccc66>")
2043	(printinl indent "WARNING: "
2044	(test-case-result-warning-ref resnode))
2045	(printinl indent "</font>")
2046	(printinl indent "</dt>")))
2047	(printinl indent "<br>")
2048
2049	;; process each expectation result.
2050	(for-each
2051	(lambda (node) (xlate (+ indent 2) node))
2052	(test-case-result-expectations-ref resnode))
2053
2054	(printinl indent "<dt>")
2055	;; print out "Result: " with the color of success or failure
2056	(if (equal? #t (test-case-result-result-ref resnode))
2057	(printime indent
2058	"<font color=#66cc66> Result: ")
2059	(printime indent
2060	"<font color=#cc6666> Result: "))
2061
2062	;; now print the actual boolean representing the result
2063	(printnl
2064	(test-case-result-result-ref resnode) " </font>")
2065	(printinl indent "</dt>")
2066
2067	(printinl indent "<dt>")
2068	;; Print the "End Test Case:" message knowing it is not only the
2069	;; anchor for the bottom of the test case, but also a link to
2070	;; the top of the test case.
2071	(printime indent
2072	"<a name=\""
2073	(end-anchor (test-case-result-id-ref resnode))
2074	"\"> "
2075	"<a href=\"#"
2076	(begin-anchor (test-case-result-id-ref resnode))
2077	"\"> End Test Case: </a> </a>")
2078
2079	;; print out the name of the package colored for success or failure.
2080	(printnl
2081	(if (equal? #t (test-case-result-result-ref resnode))
2082	"<font color=#66cc66> "
2083	"<font color=#cc6666> ")
2084	(test-case-result-message-ref resnode)
2085	" </font>")
2086	(printinl indent "</dt>")
2087
2088	(printinl indent "</dl>")
2089	(printinl indent "<br>"))
2090
2091	;; print out an expect-result
2092	((expect-result? resnode)
2093	(printinl indent "<dl>")
2094
2095	(printinl indent "<dt>")
2096	(printme
2097	"<a name=\"" (begin-anchor (expect-result-id-ref resnode))
2098	"\"> "
2099	"<a href=\"#" (end-anchor (expect-result-id-ref resnode))
2100	"\"> Begin Expectation: </a> </a> ")
2101	;; print out the message from this expectation, color coded for
2102	;; success or failure.
2103	(printnl
2104	(if (equal? #t (expect-result-result-ref resnode))
2105	"<font color=#66cc66> "
2106	"<font color=#cc6666> ")
2107	(expect-result-message-ref resnode)
2108	" </font>")
2109	(printinl indent "</dt>")
2110
2111
2112	;; dump out any warnings...
2113	(cond ((expect-result-warning? resnode)
2114	(printinl indent "<dt>")
2115	(printinl indent "<font color=#cccc66>")
2116	(printinl indent "WARNING: "
2117	(expect-result-warning-ref resnode))
2118	(printinl indent "</font>")
2119	(printinl indent "</dt>")))
2120
2121	;; print the specific type of single style expectation this was
2122	(printinl indent
2123	"<dt> Expect " (expect-result-specific-ref resnode) "</dt>")
2124
2125	(printinl indent "<dl>")
2126
2127	(printinl indent "<dt> Unevaluated: </dt>")
2128	(printinl indent "<dl>")
2129	(printinl indent
2130	"<dt> " (expect-result-unevaled-ref resnode) " </dt>")
2131	(printinl indent "</dl>")
2132
2133	(printinl indent "<dt> Evaluated: </dt>")
2134	(printinl indent "<dl>")
2135	(printinl indent
2136	"<dt> " (expect-result-evaled-ref resnode) " </dt>")
2137	(printinl indent "</dl>")
2138
2139	(printinl indent "</dl>")
2140
2141	(printinl indent "<dt>")
2142	(if (equal? #t (expect-result-result-ref resnode))
2143	(printime indent
2144	"<font color=#66cc66> Result: ")
2145	(printime indent
2146	"<font color=#cc6666> Result: "))
2147
2148	;; now print the actual boolean representing the result
2149	(printnl
2150	(expect-result-result-ref resnode) " </font>")
2151	(printinl indent "</dt>")
2152
2153	(printinl indent "<dt>")
2154	;; Print the "End Expectation:" message knowing it is not only the
2155	;; anchor for the bottom of the expectation, but also a link to
2156	;; the top of the expectation
2157	(printime indent
2158	"<a name=\""
2159	(end-anchor (expect-result-id-ref resnode))
2160	"\"> "
2161	"<a href=\"#"
2162	(begin-anchor (expect-result-id-ref resnode))
2163	"\"> End Expectation: </a> </a>")
2164
2165	;; print out the name of the expectation colored for
2166	;; success or failure.
2167	(printnl
2168	(if (equal? #t (expect-result-result-ref resnode))
2169	"<font color=#66cc66> "
2170	"<font color=#cc6666> ")
2171	(expect-result-message-ref resnode)
2172	" </font>")
2173	(printinl indent "</dt>")
2174
2175	(printinl indent "</dl>")
2176	(printinl indent "<br>"))
2177
2178	;; print out an expect-tolerance-result
2179	((expect-tolerance-result? resnode)
2180	(printinl indent "<dl>")
2181
2182	(printinl indent "<dt>")
2183	(printme
2184	"<a name=\""
2185	(begin-anchor (expect-tolerance-result-id-ref resnode))
2186	"\"> "
2187	"<a href=\"#"
2188	(end-anchor (expect-tolerance-result-id-ref resnode))
2189	"\"> Begin Expectation: </a> </a> ")
2190	;; print out the message from this expectation, color coded for
2191	;; success or failure.
2192	(printnl
2193	(if (equal? #t (expect-tolerance-result-result-ref resnode))
2194	"<font color=#66cc66> "
2195	"<font color=#cc6666> ")
2196	(expect-tolerance-result-message-ref resnode)
2197	" </font>")
2198	(printinl indent "</dt>")
2199
2200	;; dump out any warnings...
2201	(cond ((expect-tolerance-result-warning? resnode)
2202	(printinl indent "<dt>")
2203	(printinl indent "<font color=#cccc66>")
2204	(printinl indent "WARNING: "
2205	(expect-tolerance-result-warning-ref resnode))
2206	(printinl indent "</font>")
2207	(printinl indent "</dt>")))
2208
2209	(printinl indent "<dt>")
2210	(printinl indent "Expect "
2211	(expect-tolerance-result-specific-ref resnode))
2212	(printinl indent "</dt>")
2213
2214	(printinl indent "<dl>")
2215
2216	(printinl indent "<dt>")
2217	(printinl indent "Expected Value: ")
2218	(printinl indent "</dt>")
2219	(printinl indent "<dl>")
2220	(printinl indent "<dt>")
2221	(printinl indent
2222	(expect-tolerance-result-lhs-evaled-ref resnode))
2223	(printinl indent "</dt>")
2224	(printinl indent "</dl>")
2225
2226	(printinl indent "<dt>")
2227	(printinl indent "Expected Tolerance: ")
2228	(printinl indent "</dt>")
2229	(printinl indent "<dl>")
2230	(printinl indent "<dt>")
2231	(printinl indent
2232	(expect-tolerance-result-lhs-tol-evaled-ref resnode))
2233	(printinl indent "</dt>")
2234	(printinl indent "</dl>")
2235
2236	(printinl indent "<dt>")
2237	(printinl indent "Unevaluated: ")
2238	(printinl indent "</dt>")
2239	(printinl indent "<dl>")
2240	(printinl indent "<dt>")
2241	(printinl indent
2242	(expect-tolerance-result-rhs-unevaled-ref resnode))
2243	(printinl indent "</dt>")
2244	(printinl indent "</dl>")
2245
2246	(printinl indent "<dt>")
2247	(printinl indent "Evaluated: ")
2248	(printinl indent "</dt>")
2249	(printinl indent "<dl>")
2250	(printinl indent "<dt>")
2251	(printinl indent
2252	(expect-tolerance-result-rhs-evaled-ref resnode))
2253	(printinl indent "</dt>")
2254	(printinl indent "</dl>")
2255	(printinl indent "</dl>")
2256
2257	(printinl indent "<dt>")
2258	;; print the result, color coded.
2259	(if (equal? #t (expect-tolerance-result-result-ref resnode))
2260	(printime indent
2261	"<font color=#66cc66> Result: ")
2262	(printime indent
2263	"<font color=#cc6666> Result: "))
2264
2265	;; now print the actual boolean representing the result
2266	(printnl
2267	(expect-tolerance-result-result-ref resnode) " </font>")
2268	(printinl indent "</dt>")
2269
2270	(printinl indent "<dt>")
2271	;; Print the "End Expectation:" message knowing it is not only the
2272	;; anchor for the bottom of the expectation, but also a link to
2273	;; the top of the expectation
2274	(printime indent
2275	"<a name=\""
2276	(end-anchor (expect-tolerance-result-id-ref resnode))
2277	"\"> "
2278	"<a href=\"#"
2279	(begin-anchor (expect-tolerance-result-id-ref resnode))
2280	"\"> End Expectation: </a> </a>")
2281
2282	;; print out the name of the expectation colored for
2283	;; success or failure.
2284	(printnl
2285	(if (equal? #t (expect-tolerance-result-result-ref resnode))
2286	"<font color=#66cc66> "
2287	"<font color=#cc6666> ")
2288	(expect-tolerance-result-message-ref resnode)
2289	" </font>")
2290	(printinl indent "</dt>")
2291
2292	(printinl indent "</dl>")
2293	(printinl indent "<br>"))
2294
2295
2296	;; print out an expect-equivalence-result
2297	((expect-equivalence-result? resnode)
2298	(printinl indent "<dl>")
2299
2300	(printinl indent "<dt>")
2301	(printme
2302	"<a name=\""
2303	(begin-anchor (expect-equivalence-result-id-ref resnode))
2304	"\"> "
2305	"<a href=\"#"
2306	(end-anchor (expect-equivalence-result-id-ref resnode))
2307	"\"> Begin Expectation: </a> </a> ")
2308	;; print out the message from this expectation, color coded for
2309	;; success or failure.
2310	(printnl
2311	(if (equal? #t (expect-equivalence-result-result-ref resnode))
2312	"<font color=#66cc66> "
2313	"<font color=#cc6666> ")
2314	(expect-equivalence-result-message-ref resnode)
2315	" </font>")
2316	(printinl indent "</dt>")
2317
2318	;; dump out any warnings...
2319	(cond ((expect-equivalence-result-warning? resnode)
2320	(printinl indent "<dt>")
2321	(printinl indent "<font color=#cccc66>")
2322	(printinl indent "WARNING: "
2323	(expect-equivalence-result-warning-ref resnode))
2324	(printinl indent "</font>")
2325	(printinl indent "</dt>")))
2326
2327	(printinl indent "<dt>")
2328	(printinl indent "Expect "
2329	(expect-equivalence-result-specific-ref resnode))
2330	(printinl indent "</dt>")
2331
2332	(printinl indent "<dl>")
2333
2334	(printinl indent "<dt>")
2335	(printinl indent "Expected Value: ")
2336	(printinl indent "</dt>")
2337	(printinl indent "<dl>")
2338	(printinl indent "<dt>")
2339	(printinl indent
2340	(expect-equivalence-result-lhs-evaled-ref resnode))
2341	(printinl indent "</dt>")
2342	(printinl indent "</dl>")
2343
2344	(printinl indent "<dt>")
2345	(printinl indent "Unevaluated: ")
2346	(printinl indent "</dt>")
2347	(printinl indent "<dl>")
2348	(printinl indent "<dt>")
2349	(printinl indent
2350	(expect-equivalence-result-rhs-unevaled-ref resnode))
2351	(printinl indent "</dt>")
2352	(printinl indent "</dl>")
2353
2354	(printinl indent "<dt>")
2355	(printinl indent "Evaluated: ")
2356	(printinl indent "</dt>")
2357	(printinl indent "<dl>")
2358	(printinl indent "<dt>")
2359	(printinl indent
2360	(expect-equivalence-result-rhs-evaled-ref resnode))
2361	(printinl indent "</dt>")
2362	(printinl indent "</dl>")
2363
2364	(printinl indent "</dl>")
2365
2366	(printinl indent "<dt>")
2367	;; print the result, color coded.
2368	(if (equal? #t (expect-equivalence-result-result-ref resnode))
2369	(printime indent
2370	"<font color=#66cc66> Result: ")
2371	(printime indent
2372	"<font color=#cc6666> Result: "))
2373
2374	;; now print the actual boolean representing the result
2375	(printnl
2376	(expect-equivalence-result-result-ref resnode) " </font>")
2377	(printinl indent "</dt>")
2378
2379	(printinl indent "<dt>")
2380	;; Print the "End Expectation:" message knowing it is not only the
2381	;; anchor for the bottom of the expectation, but also a link to
2382	;; the top of the expectation
2383	(printime indent
2384	"<a name=\""
2385	(end-anchor (expect-equivalence-result-id-ref resnode))
2386	"\"> "
2387	"<a href=\"#"
2388	(begin-anchor (expect-equivalence-result-id-ref resnode))
2389	"\"> End Expectation: </a> </a>")
2390
2391	;; print out the name of the expectation colored for
2392	;; success or failure.
2393	(printnl
2394	(if (equal? #t (expect-equivalence-result-result-ref resnode))
2395	"<font color=#66cc66> "
2396	"<font color=#cc6666> ")
2397	(expect-equivalence-result-message-ref resnode)
2398	" </font>")
2399	(printinl indent "</dt>")
2400
2401	(printinl indent "</dl>")
2402	(printinl indent "<br>"))
2403
2404
2405	;; print out a user-invoked termination result
2406	((terminate-result? resnode)
2407	(printinl indent "<dl>")
2408	(printinl indent "<dt>")
2409	(printinl indent "Begin TERMINATION")
2410	(printinl indent "</dt>")
2411
2412	(printinl indent "<dl>")
2413	(printinl indent "<dt>")
2414	(printinl indent
2415	"Message: " (terminate-result-message-ref resnode))
2416	(printinl indent "</dt>")
2417
2418	(printinl indent "<dt>")
2419	(printinl indent
2420	"Container: " (terminate-result-container-ref resnode))
2421	(printinl indent "</dt>")
2422
2423	(printinl indent "<dt>")
2424	(printinl indent
2425	"Scope: " (terminate-result-scope-ref resnode))
2426	(printinl indent "</dt>")
2427
2428	(printinl indent "</dl>")
2429
2430	(printinl indent "<dt>")
2431	(printinl indent
2432	"Result: " (terminate-result-result-ref resnode))
2433	(printinl indent "</dt>")
2434
2435	(printinl indent "<dt>")
2436	(printinl indent "End TERMINATION")
2437	(printinl indent "</dt>")
2438	(printinl indent "</dl>"))
2439
2440	;; print out any gloss message the user might have inserted somewhere.
2441	((gloss-result? resnode)
2442	(printinl indent "<dl>")
2443	(printinl indent "<dt>")
2444	(printinl indent "GLOSS: " (gloss-result-message-ref resnode))
2445	(printinl indent "</dt>")
2446	;; dump out any warnings...
2447	(cond ((gloss-result-warning? resnode)
2448	(printinl indent "<dt>")
2449	(printinl indent "<font color=#cccc66>")
2450	(printinl indent "WARNING: "
2451	(gloss-result-warning-ref resnode))
2452	(printinl indent "</font>")
2453	(printinl indent "</dt>")))
2454
2455	(printinl indent "</dl>"))
2456
2457	;; print out any todo message the user might have inserted somewhere.
2458	((todo-result? resnode)
2459	(printinl indent "<dl>")
2460	(printinl indent "<dt>")
2461	(printinl indent "TODO: " (todo-result-message-ref resnode))
2462	(printinl indent "</dt>")
2463	;; dump out any warnings...
2464	(cond ((todo-result-warning? resnode)
2465	(printinl indent "<dt>")
2466	(printinl indent "<font color=#cccc66>")
2467	(printinl indent "WARNING: "
2468	(todo-result-warning-ref resnode))
2469	(printinl indent "</font>")
2470	(printinl indent "</dt>")))
2471	(printinl indent "</dl>")
2472	(printinl indent "<br>"))
2473
2474	;; print out any skipped thing the user may have done.
2475	((skip-result? resnode)
2476	(printinl indent "<dl>")
2477	(printinl indent "<dt>")
2478	(printinl indent "SKIP: " (skip-result-message-ref resnode))
2479	(printinl indent "</dt>")
2480	;; dump out any warnings...
2481	(cond ((skip-result-warning? resnode)
2482	(printinl indent "<dt>")
2483	(printinl indent "<font color=#cccc66>")
2484	(printinl indent "WARNING: "
2485	(skip-result-warning-ref resnode))
2486	(printinl indent "</font>")
2487	(printinl indent "</dt>")))
2488	(printinl indent "</dl>"))
2489
2490	(else
2491	(printinl indent "*** Error: Unknown result node!: " resnode))))))
2492
2493	;; Generate the web page or die if bad arguments.
2494	(cond
2495	((test-package-result? resnode)
2496
2497	;; dump the prologue for the web page
2498	(printnl "<html> <title> Testoutput </title>")
2499	(printnl "<body bgcolor=#000000 text=#3399ee link=#dddddd "
2500	"vlink=#888888>")
2501
2502	;; Dump the header that says the entire thing failed or not.
2503	(if (equal? #t (test-package-result-result-ref resnode))
2504	(printnl "<h1> ALL TESTS PASSED! </h1>")
2505	(printnl "<h1> SOME TESTS FAILED! </h1>"))
2506
2507	;; Dump the overall statistics
2508
2509	;; Dump all of the packages
2510
2511	;; Dump all of the cases
2512
2513	;; Dump all of the expectations
2514
2515	;; Dump the result tree
2516	(xlate 0 resnode)
2517
2518	;; dump the epilogue for the web page
2519	(printnl "</body> </html>")
2520
2521	;; return the toplevel package result to the caller
2522	(test-package-result-result-ref resnode))
2523
2524	(else
2525	(display "You did not pass (output-style-human ...) a valid ")
2526	(display "test package result tree.")
2527	(newline))))))
2528
2529	;; dump out simple human readable output for a result tree, and return the
2530	;; boolean result of the root.
2531	;;
2532	;; By Patrick Brannan
2533
2534	(define output-text-compact
2535	(lambda (resnode)
2536	(letrec ((xlate
2537	(lambda (indent resnode)
2538
2539	(cond
2540	;; print out a package result
2541	((test-package-result? resnode)
2542	(newline)
2543	(printinl indent
2544	"Package: '" (test-package-result-message-ref resnode) "'"
2545	(if (test-package-result-result-ref resnode)
2546	" - Passed"
2547	" - Failed"))
2548
2549	;; dump out any warnings...
2550	(cond ((test-package-result-warning? resnode)
2551	(printinl/+2 indent "WARNING: '"
2552	(test-package-result-warning-ref resnode) "'")))
2553
2554	;; process each evaluated object held in the test package
2555	(for-each
2556	(lambda (node) (xlate (+ indent 2) node))
2557	(test-package-result-exps-ref resnode)))
2558
2559	;; print out a test-case result
2560	((test-case-result? resnode)
2561	(if (test-case-result-result-ref resnode)
2562	(begin
2563	(printinl indent "Test Case: '"
2564	(test-case-result-message-ref resnode) "'"
2565	" - Passed")
2566	(cond ((test-case-result-warning? resnode)
2567	(printinl/+2 indent "WARNING: '"
2568	(test-case-result-warning-ref resnode) "'"))))
2569	(begin
2570	(printinl indent "Test Case: '"
2571	(test-case-result-message-ref resnode) "' - Failed")
2572	(cond ((test-case-result-warning? resnode)
2573	(printinl/+2 indent "WARNING: '"
2574	(test-case-result-warning-ref resnode) "'")))
2575
2576	;; process each expectation result.
2577	(for-each
2578	(lambda (node) (xlate (+ indent 2) node))
2579	(test-case-result-expectations-ref resnode)))))
2580
2581	;; print out an expect-result
2582	((expect-result? resnode)
2583	(printinl indent
2584	"Begin Expectation: "
2585	(expect-result-message-ref resnode) " ")
2586	(printinl indent "Expect "
2587	(expect-result-specific-ref resnode))
2588
2589	(cond
2590	((not (expect-result-result-ref resnode))
2591
2592	;; dump out any warnings...
2593	(cond ((expect-result-warning? resnode)
2594	(printinl indent "WARNING: "
2595	(expect-result-warning-ref resnode))))
2596
2597	(printinl/+2 indent "Unevaluated: ")
2598	(printinl/+2 indent (expect-result-unevaled-ref resnode))
2599	(printinl/+2 indent "Evaluated: ")
2600	(printinl/+2 indent (expect-result-evaled-ref resnode))
2601	(printinl indent "Result: Failed"))
2602
2603	(else
2604	(printinl indent "Result: Passed")))
2605
2606	(printinl indent
2607	"End Expectation: "
2608	(expect-result-message-ref resnode))
2609	(newline))
2610
2611	;; print out an expect-tolerance-result
2612	((expect-tolerance-result? resnode)
2613	(printinl indent
2614	"Begin Expectation: "
2615	(expect-tolerance-result-message-ref resnode))
2616	(printinl indent "Expect "
2617	(expect-tolerance-result-specific-ref resnode))
2618
2619	(cond
2620	((not (expect-tolerance-result-result-ref resnode))
2621
2622	;; dump out any warnings...
2623	(cond ((expect-tolerance-result-warning? resnode)
2624	(printinl indent "WARNING: "
2625	(expect-tolerance-result-warning-ref resnode))))
2626
2627	(printinl/+2 indent "Expected Value: ")
2628	(printinl/+2 indent
2629	(expect-tolerance-result-lhs-evaled-ref resnode))
2630	(printinl/+2 indent "Expected Tolerance: ")
2631	(printinl/+2 indent
2632	(expect-tolerance-result-lhs-tol-evaled-ref resnode))
2633	(printinl/+2 indent "Unevaluated: ")
2634	(printinl/+2 indent
2635	(expect-tolerance-result-rhs-unevaled-ref resnode))
2636	(printinl/+2 indent "Evaluated: ")
2637	(printinl/+2 indent
2638	(expect-tolerance-result-rhs-evaled-ref resnode))
2639	(printinl indent "Result: Failed"))
2640
2641	(else
2642	(printinl indent "Result: Passed")))
2643
2644	(printinl indent
2645	"End Expectation: "
2646	(expect-tolerance-result-message-ref resnode))
2647	(newline))
2648
2649	;; print out an expect-equivalence-result
2650	((expect-equivalence-result? resnode)
2651	(printinl indent
2652	"Begin Expectation: "
2653	(expect-equivalence-result-message-ref resnode))
2654	(printinl indent "Expect "
2655	(expect-equivalence-result-specific-ref resnode))
2656
2657	(cond
2658	((not (expect-equivalence-result-result-ref resnode))
2659
2660	;; dump out any warnings...
2661	(cond ((expect-equivalence-result-warning? resnode)
2662	(printinl indent "WARNING: '"
2663	(expect-equivalence-result-warning-ref resnode) "'")))
2664
2665	(printinl/+2 indent "Expected Value: ")
2666	(printinl/+2 indent
2667	(expect-equivalence-result-lhs-evaled-ref resnode))
2668	(printinl/+2 indent "Unevaluated: ")
2669	(printinl/+2 indent
2670	(expect-equivalence-result-rhs-unevaled-ref resnode))
2671	(printinl/+2 indent "Evaluated: ")
2672	(printinl/+2 indent
2673	(expect-equivalence-result-rhs-evaled-ref resnode))
2674	(printinl indent "Result: Failed"))
2675
2676	(else
2677	(printinl indent "Result: Passed")))
2678
2679	(printinl indent
2680	"End Expectation: "
2681	(expect-equivalence-result-message-ref resnode))
2682	(newline))
2683
2684	;; print out a user-invoked termination result
2685	((terminate-result? resnode)
2686	(printinl indent "Begin TERMINATION")
2687	(printinl/+2 indent
2688	"Message: '" (terminate-result-message-ref resnode) "'")
2689	(printinl/+2 indent
2690	"Container: " (terminate-result-container-ref resnode))
2691	(printinl/+2 indent
2692	"Scope: " (terminate-result-scope-ref resnode))
2693	(printinl indent
2694	"Result: " (terminate-result-result-ref resnode))
2695	(printinl indent "End TERMINATION"))
2696
2697	;; print out any gloss message the user might have inserted somewhere.
2698	((gloss-result? resnode)
2699	(printinl/+2 indent "Gloss: '" (gloss-result-message-ref
2700	resnode) "'")
2701	;; dump out any warnings...
2702	(cond ((gloss-result-warning? resnode)
2703	(printinl/+2 indent "WARNING: "
2704	(gloss-result-warning-ref resnode)))))
2705
2706	;; print out any todo message the user might have inserted somewhere.
2707	((todo-result? resnode)
2708	(printinl indent "TODO: " (todo-result-message-ref resnode))
2709	;; dump out any warnings...
2710	(cond ((todo-result-warning? resnode)
2711	(printinl indent "WARNING: "
2712	(todo-result-warning-ref resnode)))))
2713
2714	;; print out any skipped thing the user may have done.
2715	((skip-result? resnode)
2716	(printinl indent "SKIP: " (skip-result-message-ref resnode))
2717	;; dump out any warnings...
2718	(cond ((skip-result-warning? resnode)
2719	(printinl indent "WARNING: "
2720	(skip-result-warning-ref resnode))))
2721	(printinl indent ""))
2722
2723	(else
2724	(printinl indent "*** Error: Unknown result node!: " resnode))))))
2725
2726	;; figure out if I was passed the right stuff, die of not.
2727	(cond
2728	((test-package-result? resnode)
2729	;; spew out the tree
2730	;; start the translation at column zero
2731	(xlate 0 resnode)
2732	(if (equal? #t (test-package-result-result-ref resnode))
2733	(printnl "ALL TESTS SUCCESSFUL!")
2734	(printnl "SOME TESTS FAILED!"))
2735	;; return the toplevel package result to the caller
2736	(test-package-result-result-ref resnode))
2737	(else
2738	(display "You did not pass (output-style-human ...) a valid ")
2739	(display "test package result tree.")
2740	(newline))))))
2741
2742	(define output-style-human output-human-simple)
2743	(define output-style-html output-html-simple)

Note: See TracBrowser for help on using the repository browser.

Download in other formats: