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

Last change on this file since 1 was 1, checked in by azul, 14 years ago

Import everything.

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