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

Last change on this file since 3 was 3, checked in by felix winkelmann, 14 years ago

udp/test-infrastructure changes; added futures

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