0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d ==========..;;==
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b 3b ====.;; Tests.;;
0230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0270: 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 73 71 6c ======..(use sql
0280: 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 ite3 srfi-1 posi
0290: 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 x regex regex-ca
02a0: 73 65 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c se srfi-69 dot-l
02b0: 6f 63 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 ocking tcp direc
02c0: 74 6f 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 tory-utils).(imp
02d0: 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 ort (prefix sqli
02e0: 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 te3 sqlite3:)).(
02f0: 69 6e 63 6c 75 64 65 20 22 2f 6e 66 73 2f 73 69 include "/nfs/si
0300: 74 65 2f 64 69 73 6b 73 2f 69 63 66 5f 66 64 6b te/disks/icf_fdk
0310: 5f 63 77 5f 67 77 61 30 30 32 2f 73 72 65 68 6d _cw_gwa002/srehm
0320: 61 6e 2f 66 6f 73 73 69 6c 2f 64 62 69 2f 64 62 an/fossil/dbi/db
0330: 69 2e 73 63 6d 22 29 0a 28 69 6d 70 6f 72 74 20 i.scm").(import
0340: 28 70 72 65 66 69 78 20 64 62 69 20 64 62 69 3a (prefix dbi dbi:
0350: 29 29 0a 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 ))..(require-lib
0360: 72 61 72 79 20 73 74 6d 6c 29 0a 0a 28 64 65 63 rary stml)..(dec
0370: 6c 61 72 65 20 28 75 6e 69 74 20 74 65 73 74 73 lare (unit tests
0380: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0390: 73 20 6c 6f 63 6b 2d 71 75 65 75 65 29 29 0a 28 s lock-queue)).(
03a0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 declare (uses db
03b0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
03c0: 73 20 74 64 62 29 29 0a 28 64 65 63 6c 61 72 65 s tdb)).(declare
03d0: 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a (uses common)).
03e0: 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 ;; (declare (use
03f0: 73 20 64 63 6f 6d 6d 6f 6e 29 29 20 3b 3b 20 6e s dcommon)) ;; n
0400: 65 65 64 65 64 20 66 6f 72 20 74 68 65 20 73 74 eeded for the st
0410: 65 70 73 20 70 72 6f 63 65 73 73 69 6e 67 0a 28 eps processing.(
0420: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 declare (uses it
0430: 65 6d 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 ems)).(declare (
0440: 75 73 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 uses runconfig))
0450: 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 .;; (declare (us
0460: 65 73 20 73 64 62 29 29 0a 28 64 65 63 6c 61 72 es sdb)).(declar
0470: 65 20 28 75 73 65 73 20 73 65 72 76 65 72 29 29 e (uses server))
0480: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d ..(include "comm
0490: 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 on_records.scm")
04a0: 0a 28 69 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 .(include "key_r
04b0: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
04c0: 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 clude "db_record
04d0: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
04e0: 20 22 72 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 "run_records.sc
04f0: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 m").(include "te
0500: 73 74 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 st_records.scm")
0510: 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 6f ..;; Call this o
0520: 6e 65 20 74 6f 20 64 6f 20 61 6c 6c 20 74 68 65 ne to do all the
0530: 20 77 6f 72 6b 20 61 6e 64 20 67 65 74 20 61 20 work and get a
0540: 73 74 61 6e 64 61 72 64 69 7a 65 64 20 6c 69 73 standardized lis
0550: 74 20 6f 66 20 74 65 73 74 73 0a 3b 3b 20 20 20 t of tests.;;
0560: 67 65 74 73 20 70 61 74 68 73 20 66 72 6f 6d 20 gets paths from
0570: 63 6f 6e 66 69 67 73 20 61 6e 64 20 66 69 6e 64 configs and find
0580: 73 20 76 61 6c 69 64 20 74 65 73 74 73 20 0a 3b s valid tests .;
0590: 3b 20 20 20 72 65 74 75 72 6e 73 20 68 61 73 68 ; returns hash
05a0: 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 2d 2d 3e of testname -->
05b0: 20 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a 28 64 65 fullpath.;;.(de
05c0: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d fine (tests:get-
05d0: 61 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 all). (let* ((t
05e0: 65 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 20 est-search-path
05f0: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 (tests:get-tes
0600: 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 2a ts-search-path *
0610: 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 0a 20 20 configdat*))).
0620: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c (tests:get-val
0630: 69 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 id-tests (make-h
0640: 61 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d ash-table) test-
0650: 73 65 61 72 63 68 2d 70 61 74 68 29 29 29 0a 0a search-path)))..
0660: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
0670: 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d et-tests-search-
0680: 70 61 74 68 20 63 66 67 64 61 74 29 0a 20 20 28 path cfgdat). (
0690: 6c 65 74 20 28 28 70 61 74 68 73 20 28 6d 61 70 let ((paths (map
06a0: 20 63 61 64 72 20 28 63 6f 6e 66 69 67 66 3a 67 cadr (configf:g
06b0: 65 74 2d 73 65 63 74 69 6f 6e 20 63 66 67 64 61 et-section cfgda
06c0: 74 20 22 74 65 73 74 73 2d 70 61 74 68 73 22 29 t "tests-paths")
06d0: 29 29 29 0a 20 20 20 20 28 66 69 6c 74 65 72 20 ))). (filter
06e0: 28 6c 61 6d 62 64 61 20 28 64 29 0a 09 20 20 20 (lambda (d)..
06f0: 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 (if (director
0700: 79 2d 65 78 69 73 74 73 3f 20 64 29 0a 09 09 20 y-exists? d)...
0710: 20 64 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 d... (begin...
0720: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
0730: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
0740: 36 30 20 22 74 65 73 74 73 3a 67 65 74 2d 74 65 60 "tests:get-te
0750: 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 22 sts-search-path"
0760: 20 64 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 d)....(debug:pr
0770: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0780: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
0790: 47 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 G: problem with
07a0: 64 69 72 65 63 74 6f 72 79 20 22 20 64 20 22 2c directory " d ",
07b0: 20 64 72 6f 70 70 69 6e 67 20 69 74 20 66 72 6f dropping it fro
07c0: 6d 20 74 65 73 74 73 20 70 61 74 68 22 29 29 0a m tests path")).
07d0: 09 09 20 20 20 20 23 66 29 29 29 0a 09 20 20 20 .. #f)))..
07e0: 20 28 61 70 70 65 6e 64 20 70 61 74 68 73 20 28 (append paths (
07f0: 6c 69 73 74 20 28 63 6f 6e 63 20 2a 74 6f 70 70 list (conc *topp
0800: 61 74 68 2a 20 22 2f 74 65 73 74 73 22 29 29 29 ath* "/tests")))
0810: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
0820: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
0830: 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 sts test-registr
0840: 79 20 74 65 73 74 73 2d 70 61 74 68 73 29 0a 20 y tests-paths).
0850: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (if (null? test
0860: 73 2d 70 61 74 68 73 29 20 0a 20 20 20 20 20 20 s-paths) .
0870: 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 20 20 test-registry.
0880: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
0890: 68 65 64 20 28 63 61 72 20 74 65 73 74 73 2d 70 hed (car tests-p
08a0: 61 74 68 73 29 29 0a 09 09 20 28 74 61 6c 20 28 aths))... (tal (
08b0: 63 64 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 cdr tests-paths)
08c0: 29 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 78 ))..(if (file-ex
08d0: 69 73 74 73 3f 20 68 65 64 29 0a 09 20 20 20 20 ists? hed)..
08e0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
08f0: 61 20 28 74 65 73 74 2d 70 61 74 68 29 0a 09 09 a (test-path)...
0900: 09 28 6c 65 74 2a 20 28 28 74 6e 61 6d 65 20 20 .(let* ((tname
0910: 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 (last (string-s
0920: 70 6c 69 74 20 74 65 73 74 2d 70 61 74 68 20 22 plit test-path "
0930: 2f 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 /")))....
0940: 28 74 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 74 (tconfig (conc t
0950: 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
0960: 6f 6e 66 69 67 22 29 29 29 0a 09 09 09 20 20 28 onfig"))).... (
0970: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 68 61 if (and (not (ha
0980: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0990: 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 ault test-regist
09a0: 72 79 20 74 6e 61 6d 65 20 23 66 29 29 0a 09 09 ry tname #f))...
09b0: 09 09 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 .. (file-exist
09c0: 73 3f 20 74 63 6f 6e 66 69 67 29 29 0a 09 09 09 s? tconfig))....
09d0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
09e0: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 e-set! test-regi
09f0: 73 74 72 79 20 74 6e 61 6d 65 20 74 65 73 74 2d stry tname test-
0a00: 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 path))))...
0a10: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 68 65 64 (glob (conc hed
0a20: 20 22 2f 2a 22 29 29 29 29 0a 09 28 69 66 20 28 "/*"))))..(if (
0a30: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 null? tal)..
0a40: 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 09 20 test-registry..
0a50: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
0a60: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
0a70: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
0a80: 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d :filter-test-nam
0a90: 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 es test-names te
0aa0: 73 74 2d 70 61 74 74 73 29 0a 20 20 28 64 65 6c st-patts). (del
0ab0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 20 ete-duplicates.
0ac0: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
0ad0: 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 20 a (testname)..
0ae0: 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 (tests:match
0af0: 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e test-patts testn
0b00: 61 6d 65 20 23 66 29 29 0a 09 20 20 20 74 65 73 ame #f)).. tes
0b10: 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 69 t-names)))..;; i
0b20: 74 65 6d 6d 61 70 20 69 73 20 61 20 6c 69 73 74 temmap is a list
0b30: 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 70 61 74 of testname pat
0b40: 74 65 72 6e 73 20 74 6f 20 6d 61 70 73 0a 3b 3b terns to maps.;;
0b50: 20 20 20 20 20 74 65 73 74 31 20 2e 2a 2f 62 61 test1 .*/ba
0b60: 72 2f 28 5c 64 2b 29 20 66 6f 6f 2f 5c 31 0a 3b r/(\d+) foo/\1.;
0b70: 3b 20 20 20 20 20 25 20 20 20 20 20 66 6f 6f 2f ; % foo/
0b80: 28 5b 5e 2f 5d 2b 29 20 20 5c 31 2f 62 61 72 0a ([^/]+) \1/bar.
0b90: 3b 3b 0a 3b 3b 20 23 20 4e 4f 54 45 3a 20 74 68 ;;.;; # NOTE: th
0ba0: 65 20 6c 69 6e 65 20 77 69 74 68 20 74 68 65 20 e line with the
0bb0: 73 69 6e 67 6c 65 20 25 20 63 6f 75 6c 64 20 62 single % could b
0bc0: 65 20 74 68 65 20 72 65 73 75 6c 74 20 6f 66 0a e the result of.
0bd0: 3b 3b 20 23 20 20 20 20 20 20 20 69 74 65 6d 6d ;; # itemm
0be0: 61 70 20 65 6e 74 72 79 20 69 6e 20 72 65 71 75 ap entry in requ
0bf0: 69 72 65 6d 65 6e 74 73 20 28 6c 65 67 61 63 79 irements (legacy
0c00: 29 2e 20 54 68 65 20 69 74 65 6d 6d 61 70 0a 3b ). The itemmap.;
0c10: 3b 20 23 20 20 20 20 20 20 20 72 65 71 75 69 72 ; # requir
0c20: 65 6d 65 6e 74 73 20 65 6e 74 72 79 20 69 73 20 ements entry is
0c30: 64 65 70 72 65 63 61 74 65 64 0a 3b 3b 0a 28 64 deprecated.;;.(d
0c40: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
0c50: 2d 69 74 65 6d 6d 61 70 73 20 74 63 6f 6e 66 69 -itemmaps tconfi
0c60: 67 29 0a 20 20 28 6c 65 74 20 28 28 62 61 73 65 g). (let ((base
0c70: 2d 69 74 65 6d 6d 61 70 20 20 28 63 6f 6e 66 69 -itemmap (confi
0c80: 67 66 3a 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 gf:lookup tconfi
0c90: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
0ca0: 20 22 69 74 65 6d 6d 61 70 22 29 29 0a 09 28 69 "itemmap"))..(i
0cb0: 74 65 6d 6d 61 70 2d 74 61 62 6c 65 20 28 63 6f temmap-table (co
0cc0: 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f nfigf:get-sectio
0cd0: 6e 20 74 63 6f 6e 66 69 67 20 22 69 74 65 6d 6d n tconfig "itemm
0ce0: 61 70 22 29 29 29 0a 20 20 20 20 28 61 70 70 65 ap"))). (appe
0cf0: 6e 64 20 28 69 66 20 62 61 73 65 2d 69 74 65 6d nd (if base-item
0d00: 6d 61 70 0a 09 09 28 6c 69 73 74 20 28 6c 69 73 map...(list (lis
0d10: 74 20 22 25 22 20 62 61 73 65 2d 69 74 65 6d 6d t "%" base-itemm
0d20: 61 70 29 29 0a 09 09 27 28 29 29 0a 09 20 20 20 ap))...'())..
0d30: 20 28 69 66 20 69 74 65 6d 6d 61 70 2d 74 61 62 (if itemmap-tab
0d40: 6c 65 0a 09 09 69 74 65 6d 6d 61 70 2d 74 61 62 le...itemmap-tab
0d50: 6c 65 0a 09 09 27 28 29 29 29 29 29 0a 0a 3b 3b le...'()))))..;;
0d60: 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f 66 given a list of
0d70: 20 69 74 65 6d 6d 61 70 73 20 28 74 65 73 74 6e itemmaps (testn
0d80: 61 6d 65 20 2e 20 6d 61 70 29 2c 20 72 65 74 75 ame . map), retu
0d90: 72 6e 20 74 68 65 20 66 69 72 73 74 20 6d 61 74 rn the first mat
0da0: 63 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ch.;;.(define (t
0db0: 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 65 6d ests:lookup-item
0dc0: 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 74 65 73 map itemmaps tes
0dd0: 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 tname). (let ((
0de0: 62 65 73 74 2d 6d 61 74 63 68 65 73 20 28 66 69 best-matches (fi
0df0: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 69 74 lter (lambda (it
0e00: 65 6d 6d 61 70 29 0a 09 09 09 09 28 74 65 73 74 emmap).....(test
0e10: 73 3a 6d 61 74 63 68 20 28 63 61 72 20 69 74 65 s:match (car ite
0e20: 6d 6d 61 70 29 20 74 65 73 74 6e 61 6d 65 20 23 mmap) testname #
0e30: 66 29 29 0a 09 09 09 20 20 20 20 20 20 69 74 65 f)).... ite
0e40: 6d 6d 61 70 73 29 29 29 0a 20 20 20 20 28 69 66 mmaps))). (if
0e50: 20 28 6e 75 6c 6c 3f 20 62 65 73 74 2d 6d 61 74 (null? best-mat
0e60: 63 68 65 73 29 0a 09 23 66 0a 09 28 6c 65 74 20 ches)..#f..(let
0e70: 28 28 72 65 73 20 28 63 61 72 20 62 65 73 74 2d ((res (car best-
0e80: 6d 61 74 63 68 65 73 29 29 29 0a 09 20 20 3b 3b matches))).. ;;
0e90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
0ea0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0eb0: 74 2a 20 22 72 65 73 3d 22 20 72 65 73 29 0a 09 t* "res=" res)..
0ec0: 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 73 74 (cond.. ((st
0ed0: 72 69 6e 67 3f 20 72 65 73 29 20 72 65 73 29 20 ring? res) res)
0ee0: 3b 3b 3b 20 46 49 58 20 54 48 45 20 52 4f 4f 54 ;;; FIX THE ROOT
0ef0: 20 43 41 55 53 45 20 48 45 52 45 20 2e 2e 2e 2e CAUSE HERE ....
0f00: 0a 09 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 73 .. ((null? res
0f10: 29 20 20 20 23 66 29 0a 09 20 20 20 28 28 73 74 ) #f).. ((st
0f20: 72 69 6e 67 3f 20 28 63 64 72 20 72 65 73 29 29 ring? (cdr res))
0f30: 20 28 63 64 72 20 72 65 73 29 29 20 20 3b 3b 20 (cdr res)) ;;
0f40: 69 74 20 69 73 20 61 20 70 61 69 72 0a 09 20 20 it is a pair..
0f50: 20 28 28 73 74 72 69 6e 67 3f 20 28 63 61 64 72 ((string? (cadr
0f60: 20 72 65 73 29 29 28 63 61 64 72 20 72 65 73 29 res))(cadr res)
0f70: 29 20 3b 3b 20 69 74 20 69 73 20 61 20 6c 69 73 ) ;; it is a lis
0f80: 74 0a 09 20 20 20 28 65 6c 73 65 20 63 61 64 72 t.. (else cadr
0f90: 20 72 65 73 29 29 29 29 29 29 0a 0a 3b 3b 20 72 res))))))..;; r
0fa0: 65 74 75 72 6e 20 69 74 65 6d 73 20 67 69 76 65 eturn items give
0fb0: 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a 28 64 65 66 n config.;;.(def
0fc0: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 69 ine (tests:get-i
0fd0: 74 65 6d 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 tems tconfig).
0fe0: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
0ff0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
1000: 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 f/default tconfi
1010: 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b g "items" #f)) ;
1020: 3b 20 69 74 65 6d 73 20 34 0a 09 28 69 74 65 6d ; items 4..(item
1030: 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 stable (hash-tab
1040: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
1050: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 config "itemstab
1060: 6c 65 22 20 23 66 29 29 29 20 0a 20 20 20 20 3b le" #f))) . ;
1070: 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d ; if either item
1080: 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 s or items table
1090: 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 is a proc retur
10a0: 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e n it so test run
10b0: 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 70 72 6f 63 ning. ;; proc
10c0: 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 ess can know to
10d0: 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 call items:get-i
10e0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
10f0: 0a 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 . ;; if eithe
1100: 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 r is a list and
1110: 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 none is a proc g
1120: 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c o ahead and call
1130: 20 67 65 74 2d 69 74 65 6d 73 0a 20 20 20 20 3b get-items. ;
1140: 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 ; otherwise retu
1150: 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 rn #f - this is
1160: 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 not an iterated
1170: 74 65 73 74 0a 20 20 20 20 28 63 6f 6e 64 0a 20 test. (cond.
1180: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
1190: 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 20 20 items) .
11a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
11b0: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
11c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d -log-port* "item
11d0: 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 s is a procedure
11e0: 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
11f0: 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 29 r"). items)
1200: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 ;; c
1210: 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 alc later. (
1220: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
1230: 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 64 stable). (d
1240: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1250: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
1260: 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 6c 65 ort* "itemstable
1270: 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
1280: 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
1290: 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 74 61 "). itemsta
12a0: 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 ble) ;; ca
12b0: 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 28 lc later. ((
12c0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
12d0: 78 29 0a 09 09 28 6c 65 74 20 28 28 76 61 6c 20 x)...(let ((val
12e0: 28 63 61 72 20 78 29 29 29 0a 09 09 20 20 28 69 (car x)))... (i
12f0: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
1300: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 20 20 l) val #f)))..
1310: 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 (append (if
1320: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
1330: 65 6d 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 ems '())...
1340: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
1350: 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 stable) itemstab
1360: 6c 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 le '()))).
1370: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
1380: 0a 20 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 . ((or (list
1390: 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 ? items)(list? i
13a0: 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 temstable)) ;; c
13b0: 61 6c 63 20 6e 6f 77 0a 20 20 20 20 20 20 28 64 alc now. (d
13c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
13d0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
13e0: 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e 64 20 ort* "items and
13f0: 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c itemstable are l
1400: 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e ists, calc now\n
1410: 22 0a 09 09 09 22 20 20 20 20 69 74 65 6d 73 3a "...." items:
1420: 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 " items " items
1430: 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 table: " itemsta
1440: 62 6c 65 29 0a 20 20 20 20 20 20 28 69 74 65 6d ble). (item
1450: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
1460: 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 -config tconfig)
1470: 29 0a 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 ). (else #f)
1480: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )))
1490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
14a0: 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 0a 0a not iterated...
14b0: 3b 3b 20 72 65 74 75 72 6e 73 20 77 61 69 74 6f ;; returns waito
14c0: 6e 73 20 77 61 69 74 6f 72 73 20 74 63 6f 6e 66 ns waitors tconf
14d0: 69 67 64 61 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 igdat.;;.(define
14e0: 20 28 74 65 73 74 73 3a 67 65 74 2d 77 61 69 74 (tests:get-wait
14f0: 6f 6e 73 20 74 65 73 74 2d 6e 61 6d 65 20 61 6c ons test-name al
1500: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
1510: 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e ). (let* ((con
1520: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
1530: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
1540: 6e 61 6d 65 20 61 6c 6c 2d 74 65 73 74 73 2d 72 name all-tests-r
1550: 65 67 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d egistry 'return-
1560: 70 72 6f 63 73 29 29 29 0a 20 20 20 20 20 28 6c procs))). (l
1570: 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 et ((instr (if c
1580: 6f 6e 66 69 67 20 0a 09 09 20 20 20 20 20 20 28 onfig ... (
1590: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f config-lookup co
15a0: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
15b0: 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 ts" "waiton")...
15c0: 20 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 (begin ;;
15d0: 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 No config means
15e0: 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 this is a non-ex
15f0: 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 28 istant test....(
1600: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
1610: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
1620: 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 73 -port* "non-exis
1630: 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 tent required te
1640: 73 74 20 5c 22 22 20 74 65 73 74 2d 6e 61 6d 65 st \"" test-name
1650: 20 22 5c 22 22 29 0a 09 09 09 28 65 78 69 74 20 "\"")....(exit
1660: 31 29 29 29 29 0a 09 20 20 20 28 69 6e 73 74 72 1)))).. (instr
1670: 32 20 28 69 66 20 63 6f 6e 66 69 67 0a 09 09 20 2 (if config...
1680: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
1690: 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 okup config "req
16a0: 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 uirements" "wait
16b0: 6f 72 22 29 0a 09 09 20 20 20 20 20 20 20 22 22 or")... ""
16c0: 29 29 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 ))). (debu
16d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a g:print-info 8 *
16e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
16f0: 2a 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e * "waitons strin
1700: 67 20 69 73 20 22 20 69 6e 73 74 72 20 22 2c 20 g is " instr ",
1710: 77 61 69 74 6f 72 73 20 73 74 72 69 6e 67 20 69 waitors string i
1720: 73 20 22 20 69 6e 73 74 72 32 29 0a 20 20 20 20 s " instr2).
1730: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 77 61 69 (let ((newwai
1740: 74 6f 6e 73 0a 09 20 20 20 20 20 20 28 73 74 72 tons.. (str
1750: 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a ing-split (cond.
1760: 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 ... ((proced
1770: 75 72 65 3f 20 69 6e 73 74 72 29 20 3b 3b 20 68 ure? instr) ;; h
1780: 65 72 65 20 0a 09 09 09 20 20 20 20 20 20 28 6c ere .... (l
1790: 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 et ((res (instr)
17a0: 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 )).....(debug:pr
17b0: 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 int-info 8 *defa
17c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
17d0: 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 aiton procedure
17e0: 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e results in strin
17f0: 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 g " res " for te
1800: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a st " test-name).
1810: 09 09 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 ....res))....
1820: 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 ((string? inst
1830: 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 r) instr)...
1840: 09 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 . (else ....
1850: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 ;; NOTE: T
1860: 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 his is actually
1870: 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a the case of *no*
1880: 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 waitons! ;; (de
1890: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
18a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
18b0: 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 ort* "something
18c0: 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 went wrong in pr
18d0: 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 ocessing waitons
18e0: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
18f0: 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 -name)....
1900: 22 22 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 "")))).. (ne
1910: 77 77 61 69 74 6f 72 73 0a 09 20 20 20 20 20 20 wwaitors..
1920: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 (string-split (c
1930: 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 70 72 ond.... ((pr
1940: 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 32 29 ocedure? instr2)
1950: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
1960: 28 72 65 73 20 28 69 6e 73 74 72 32 29 29 29 0a (res (instr2))).
1970: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
1980: 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 -info 8 *default
1990: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
19a0: 6f 72 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 or procedure res
19b0: 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 ults in string "
19c0: 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 res " for test
19d0: 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 " test-name)....
19e0: 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 .res)).... (
19f0: 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 29 (string? instr2)
1a00: 20 20 20 20 20 69 6e 73 74 72 32 29 0a 09 09 09 instr2)....
1a10: 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 (else ....
1a20: 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 ;; NOTE: Th
1a30: 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
1a40: 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
1a50: 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 waitons! ;; (deb
1a60: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
1a70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1a80: 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 rt* "something w
1a90: 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f ent wrong in pro
1aa0: 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 cessing waitons
1ab0: 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d for test " test-
1ac0: 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 name).... "
1ad0: 22 29 29 29 29 29 0a 09 20 28 76 61 6c 75 65 73 "))))).. (values
1ae0: 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 6f .. ;; the waito
1af0: 6e 73 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c ns.. (filter (l
1b00: 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 ambda (x)...
1b10: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
1b20: 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d ref/default all-
1b30: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 tests-registry x
1b40: 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 #f)....#t....(b
1b50: 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 egin.... (debug
1b60: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
1b70: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1b80: 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e * "test " test-n
1b90: 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f ame " has unreco
1ba0: 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 gnised waiton te
1bb0: 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 stname " x)....
1bc0: 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 #f)))... newwa
1bd0: 69 74 6f 6e 73 29 0a 09 20 20 28 66 69 6c 74 65 itons).. (filte
1be0: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
1bf0: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
1c00: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
1c10: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
1c20: 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a 09 ry x #f)....#t..
1c30: 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 ..(begin.... (d
1c40: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
1c50: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1c60: 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 65 port* "test " te
1c70: 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 6e st-name " has un
1c80: 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 6f recognised waito
1c90: 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 0a n testname " x).
1ca0: 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 6e ... #f)))... n
1cb0: 65 77 77 61 69 74 6f 72 73 29 0a 09 20 20 63 6f ewwaitors).. co
1cc0: 6e 66 69 67 29 29 29 29 29 0a 09 09 09 09 09 20 nfig)))))......
1cd0: 20 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 77 61 .;; given wa
1ce0: 69 74 69 6e 67 2d 74 65 73 74 20 74 68 61 74 20 iting-test that
1cf0: 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 61 is waiting on wa
1d00: 69 74 6f 6e 2d 74 65 73 74 20 65 78 74 65 6e 64 iton-test extend
1d10: 20 74 65 73 74 2d 70 61 74 74 20 61 70 70 72 6f test-patt appro
1d20: 70 72 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 20 priately.;;.;;
1d30: 67 65 6e 6c 69 62 2f 74 65 73 74 63 6f 6e 66 69 genlib/testconfi
1d40: 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 g
1d50: 73 69 6d 2f 74 65 73 74 63 6f 6e 66 69 67 0a 3b sim/testconfig.;
1d60: 3b 20 20 67 65 6e 6c 69 62 2f 73 63 68 20 20 20 ; genlib/sch
1d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d80: 20 20 20 73 69 6d 2f 73 63 68 2f 63 65 6c 6c 31 sim/sch/cell1
1d90: 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 72 65 .;;.;; [require
1da0: 6d 65 6e 74 73 5d 20 20 20 20 20 20 20 20 20 20 ments]
1db0: 20 20 20 20 20 20 20 20 5b 72 65 71 75 69 72 65 [require
1dc0: 6d 65 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 20 20 ments].;;
1dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1de0: 20 20 20 20 20 20 20 20 20 20 20 6d 6f 64 65 20 mode
1df0: 69 74 65 6d 77 61 69 74 0a 3b 3b 20 20 20 20 20 itemwait.;;
1e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 20 74 # t
1e20: 72 69 6d 20 6f 66 66 20 74 68 65 20 63 65 6c 6c rim off the cell
1e30: 20 74 6f 20 64 65 74 65 72 6d 69 6e 65 20 77 68 to determine wh
1e40: 61 74 20 74 6f 20 72 75 6e 20 66 6f 72 20 67 65 at to run for ge
1e50: 6e 6c 69 62 0a 3b 3b 20 20 20 20 20 20 20 20 20 nlib.;;
1e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e70: 20 20 20 20 20 20 20 20 20 69 74 65 6d 6d 61 70 itemmap
1e80: 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 20 20 20 20 20 /.*.;;.;;
1e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ea0: 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 74 wait
1eb0: 69 6e 67 2d 74 65 73 74 20 69 73 20 77 61 69 74 ing-test is wait
1ec0: 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 ing on waiton-te
1ed0: 73 74 20 73 6f 20 77 65 20 6e 65 65 64 20 74 6f st so we need to
1ee0: 20 63 72 65 61 74 65 20 61 20 70 61 74 74 65 72 create a patter
1ef0: 6e 20 66 6f 72 20 77 61 69 74 6f 6e 2d 74 65 73 n for waiton-tes
1f00: 74 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d t given waiting-
1f10: 74 65 73 74 20 61 6e 64 20 69 74 65 6d 6d 61 70 test and itemmap
1f20: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
1f30: 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 extend-test-patt
1f40: 73 20 74 65 73 74 2d 70 61 74 74 20 77 61 69 74 s test-patt wait
1f50: 69 6e 67 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d ing-test waiton-
1f60: 74 65 73 74 20 69 74 65 6d 6d 61 70 73 29 0a 20 test itemmaps).
1f70: 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 6d 61 70 (let* ((itemmap
1f80: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 73 (tests
1f90: 3a 6c 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 :lookup-itemmap
1fa0: 69 74 65 6d 6d 61 70 73 20 77 61 69 74 6f 6e 2d itemmaps waiton-
1fb0: 74 65 73 74 29 29 0a 09 20 28 70 61 74 74 73 20 test)).. (patts
1fc0: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
1fd0: 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 ng-split test-pa
1fe0: 74 74 20 22 2c 22 29 29 0a 09 20 28 77 61 69 74 tt ",")).. (wait
1ff0: 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 ing-test-len (+
2000: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 (string-length w
2010: 61 69 74 69 6e 67 2d 74 65 73 74 29 20 31 29 29 aiting-test) 1))
2020: 0a 09 20 28 70 61 74 74 73 2d 77 61 69 74 6f 6e .. (patts-waiton
2030: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
2040: 61 20 28 78 29 20 20 3b 3b 20 66 6f 72 20 65 61 a (x) ;; for ea
2050: 63 68 20 69 6e 63 6f 6d 69 6e 67 20 70 61 74 74 ch incoming patt
2060: 20 74 68 61 74 20 6d 61 74 63 68 65 73 20 74 68 that matches th
2070: 65 20 77 61 69 74 69 6e 67 20 74 65 73 74 0a 09 e waiting test..
2080: 09 09 09 20 20 28 6c 65 74 2a 20 28 28 6d 6f 64 ... (let* ((mod
2090: 70 61 74 74 20 28 69 66 20 69 74 65 6d 6d 61 70 patt (if itemmap
20a0: 20 28 64 62 3a 63 6f 6e 76 65 72 74 2d 74 65 73 (db:convert-tes
20b0: 74 2d 69 74 65 6d 70 61 74 68 20 78 20 69 74 65 t-itempath x ite
20c0: 6d 6d 61 70 29 20 78 29 29 20 0a 09 09 09 09 09 mmap) x)) ......
20d0: 20 28 6e 65 77 70 61 74 74 20 28 63 6f 6e 63 20 (newpatt (conc
20e0: 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f 22 20 waiton-test "/"
20f0: 28 73 75 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 (substring modpa
2100: 74 74 20 77 61 69 74 69 6e 67 2d 74 65 73 74 2d tt waiting-test-
2110: 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 len (string-leng
2120: 74 68 20 6d 6f 64 70 61 74 74 29 29 29 29 29 0a th modpatt))))).
2130: 09 09 09 09 20 20 20 20 3b 3b 20 28 63 6f 6e 63 .... ;; (conc
2140: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f waiting-test "/
2150: 2c 22 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 ," waiting-test
2160: 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d "/" (substring m
2170: 6f 64 70 61 74 74 20 77 61 69 74 6f 6e 2d 74 65 odpatt waiton-te
2180: 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c st-len (string-l
2190: 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 29 29 ength modpatt)))
21a0: 29 29 0a 09 09 09 09 20 20 20 20 3b 3b 20 28 70 ))..... ;; (p
21b0: 72 69 6e 74 20 22 69 6e 20 6d 61 70 2c 20 78 3d rint "in map, x=
21c0: 22 20 78 20 22 2c 20 6e 65 77 70 61 74 74 3d 22 " x ", newpatt="
21d0: 20 6e 65 77 70 61 74 74 29 0a 09 09 09 09 20 20 newpatt).....
21e0: 20 20 6e 65 77 70 61 74 74 29 29 0a 09 09 09 09 newpatt)).....
21f0: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
2200: 28 78 29 0a 09 09 09 09 09 20 20 28 65 71 3f 20 (x)...... (eq?
2210: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
2220: 20 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d 74 (conc waiting-t
2230: 65 73 74 20 22 2f 22 29 20 78 29 20 30 29 29 20 est "/") x) 0))
2240: 3b 3b 20 69 73 20 74 68 69 73 20 70 61 74 74 20 ;; is this patt
2250: 70 65 72 74 69 6e 65 6e 74 20 74 6f 20 74 68 65 pertinent to the
2260: 20 77 61 69 74 69 6e 67 20 74 65 73 74 0a 09 09 waiting test...
2270: 09 09 09 70 61 74 74 73 29 29 29 29 0a 20 20 20 ...patts)))).
2280: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2290: 65 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 erse (delete-dup
22a0: 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 licates (append
22b0: 70 61 74 74 73 20 28 69 66 20 28 6e 75 6c 6c 3f patts (if (null?
22c0: 20 70 61 74 74 73 2d 77 61 69 74 6f 6e 29 0a 09 patts-waiton)..
22d0: 09 09 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 ...... (list
22e0: 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 (conc waiton-te
22f0: 73 74 20 22 2f 25 22 29 29 20 3b 3b 20 72 65 61 st "/%")) ;; rea
2300: 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 61 64 lly shouldn't ad
2310: 64 20 74 68 65 20 77 61 69 74 6f 6e 20 66 6f 72 d the waiton for
2320: 63 65 66 75 6c 6c 79 20 6c 69 6b 65 20 74 68 69 cefully like thi
2330: 73 0a 09 09 09 09 09 09 09 20 20 20 20 20 70 61 s........ pa
2340: 74 74 73 2d 77 61 69 74 6f 6e 29 29 29 0a 09 09 tts-waiton)))...
2350: 09 22 2c 22 29 29 29 0a 0a 0a 20 20 0a 3b 3b 20 .",")))... .;;
2360: 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d tests:glob-like-
2370: 6d 61 74 63 68 20 0a 28 64 65 66 69 6e 65 20 28 match .(define (
2380: 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d tests:glob-like-
2390: 6d 61 74 63 68 20 70 61 74 74 20 73 74 72 29 20 match patt str)
23a0: 0a 20 20 28 6c 65 74 20 28 28 6c 69 6b 65 20 28 . (let ((like (
23b0: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
23c0: 22 25 22 20 70 61 74 74 29 29 29 0a 20 20 20 20 "%" patt))).
23d0: 28 6c 65 74 2a 20 28 28 6e 6f 74 70 61 74 74 20 (let* ((notpatt
23e0: 20 28 65 71 75 61 6c 3f 20 28 73 75 62 73 74 72 (equal? (substr
23f0: 69 6e 67 2d 69 6e 64 65 78 20 22 7e 22 20 70 61 ing-index "~" pa
2400: 74 74 29 20 30 29 29 0a 09 20 20 20 28 6e 65 77 tt) 0)).. (new
2410: 70 61 74 74 20 20 28 69 66 20 6e 6f 74 70 61 74 patt (if notpat
2420: 74 20 28 73 75 62 73 74 72 69 6e 67 20 70 61 74 t (substring pat
2430: 74 20 31 29 20 70 61 74 74 29 29 0a 09 20 20 20 t 1) patt))..
2440: 28 66 69 6e 70 61 74 74 20 20 28 69 66 20 6c 69 (finpatt (if li
2450: 6b 65 0a 09 09 09 28 73 74 72 69 6e 67 2d 73 75 ke....(string-su
2460: 62 73 74 69 74 75 74 65 20 28 72 65 67 65 78 70 bstitute (regexp
2470: 20 22 25 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 "%") ".*" newpa
2480: 74 74 20 23 66 29 0a 09 09 09 28 73 74 72 69 6e tt #f)....(strin
2490: 67 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 g-substitute (re
24a0: 67 65 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 gexp "\\*") ".*"
24b0: 20 6e 65 77 70 61 74 74 20 23 66 29 29 29 0a 09 newpatt #f)))..
24c0: 20 20 20 28 72 65 73 20 20 20 20 20 20 23 66 29 (res #f)
24d0: 29 0a 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e ). ;; (prin
24e0: 74 20 22 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 t "tests:glob-li
24f0: 6b 65 2d 6d 61 74 63 68 20 3d 3e 20 6e 6f 74 70 ke-match => notp
2500: 61 74 74 3a 20 22 20 6e 6f 74 70 61 74 74 20 22 att: " notpatt "
2510: 2c 20 6e 65 77 70 61 74 74 3a 20 22 20 6e 65 77 , newpatt: " new
2520: 70 61 74 74 20 22 2c 20 66 69 6e 70 61 74 74 3a patt ", finpatt:
2530: 20 22 20 66 69 6e 70 61 74 74 29 0a 20 20 20 20 " finpatt).
2540: 20 20 28 73 65 74 21 20 72 65 73 20 28 73 74 72 (set! res (str
2550: 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 ing-match (regex
2560: 70 20 66 69 6e 70 61 74 74 20 28 69 66 20 6c 69 p finpatt (if li
2570: 6b 65 20 23 74 20 23 66 29 29 20 73 74 72 29 29 ke #t #f)) str))
2580: 0a 20 20 20 20 20 20 28 69 66 20 6e 6f 74 70 61 . (if notpa
2590: 74 74 20 28 6e 6f 74 20 72 65 73 29 20 72 65 73 tt (not res) res
25a0: 29 29 29 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d ))))..;; if item
25b0: 70 61 74 68 20 69 73 20 23 66 20 74 68 65 6e 20 path is #f then
25c0: 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 look only at the
25d0: 20 74 65 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b testname part.;
25e0: 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ;.(define (tests
25f0: 3a 6d 61 74 63 68 20 70 61 74 74 65 72 6e 73 20 :match patterns
2600: 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 testname itempat
2610: 68 20 23 21 6b 65 79 20 28 72 65 71 75 69 72 65 h #!key (require
2620: 64 20 27 28 29 29 29 0a 20 20 28 69 66 20 28 73 d '())). (if (s
2630: 74 72 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 tring? patterns)
2640: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 . (let ((pa
2650: 74 74 73 20 28 61 70 70 65 6e 64 20 28 73 74 72 tts (append (str
2660: 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 ing-split patter
2670: 6e 73 20 22 2c 22 29 20 72 65 71 75 69 72 65 64 ns ",") required
2680: 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 )))..(if (null?
2690: 70 61 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 patts) ;;; no pa
26a0: 74 74 65 72 6e 28 73 29 20 6d 65 61 6e 73 20 6e ttern(s) means n
26b0: 6f 20 6d 61 74 63 68 0a 09 20 20 20 20 23 66 0a o match.. #f.
26c0: 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
26d0: 28 70 61 74 74 20 28 63 61 72 20 70 61 74 74 73 (patt (car patts
26e0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c ))... (tal
26f0: 20 20 28 63 64 72 20 70 61 74 74 73 29 29 29 0a (cdr patts))).
2700: 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 . ;; (print
2710: 20 22 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 "loop: patt: "
2720: 70 61 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 patt ", tal " ta
2730: 6c 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 l).. (if (s
2740: 74 72 69 6e 67 3d 3f 20 70 61 74 74 20 22 22 29 tring=? patt "")
2750: 0a 09 09 20 20 23 66 20 3b 3b 20 6e 6f 74 68 69 ... #f ;; nothi
2760: 6e 67 20 65 76 65 72 20 6d 61 74 63 68 65 73 20 ng ever matches
2770: 65 6d 70 74 79 20 73 74 72 69 6e 67 20 2d 20 70 empty string - p
2780: 6f 6c 69 63 79 0a 09 09 20 20 28 6c 65 74 2a 20 olicy... (let*
2790: 28 28 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 ((patt-parts (st
27a0: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
27b0: 78 70 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c xp "^([^\\/]*)(\
27c0: 5c 2f 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 \/(.*)|)$") patt
27d0: 29 29 0a 09 09 09 20 28 74 65 73 74 2d 70 61 74 )).... (test-pat
27e0: 74 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 t (cadr patt-pa
27f0: 72 74 73 29 29 0a 09 09 09 20 28 69 74 65 6d 2d rts)).... (item-
2800: 70 61 74 74 20 20 28 63 61 64 64 64 72 20 70 61 patt (cadddr pa
2810: 74 74 2d 70 61 72 74 73 29 29 29 0a 09 09 20 20 tt-parts)))...
2820: 20 20 3b 3b 20 73 70 65 63 69 61 6c 20 63 61 73 ;; special cas
2830: 65 3a 20 74 65 73 74 20 76 73 2e 20 74 65 73 74 e: test vs. test
2840: 2f 0a 09 09 20 20 20 20 3b 3b 20 20 20 74 65 73 /... ;; tes
2850: 74 20 20 3d 3e 20 22 74 65 73 74 22 20 22 25 22 t => "test" "%"
2860: 0a 09 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 ... ;; test
2870: 2f 20 3d 3e 20 22 74 65 73 74 22 20 22 22 0a 09 / => "test" ""..
2880: 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e . (if (and (n
2890: 6f 74 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e ot (substring-in
28a0: 64 65 78 20 22 2f 22 20 70 61 74 74 29 29 20 3b dex "/" patt)) ;
28b0: 3b 20 6e 6f 20 73 6c 61 73 68 20 69 6e 20 74 68 ; no slash in th
28c0: 65 20 6f 72 69 67 69 6e 61 6c 0a 09 09 09 20 20 e original....
28d0: 20 20 20 28 6f 72 20 28 6e 6f 74 20 69 74 65 6d (or (not item
28e0: 2d 70 61 74 74 29 0a 09 09 09 09 20 28 65 71 75 -patt)..... (equ
28f0: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 74 20 22 22 al? item-patt ""
2900: 29 29 29 20 20 20 20 20 20 3b 3b 20 73 68 6f 75 ))) ;; shou
2910: 6c 64 20 61 6c 77 61 79 73 20 62 65 20 74 72 75 ld always be tru
2920: 65 20 74 68 61 74 20 69 74 65 6d 2d 70 61 74 74 e that item-patt
2930: 20 69 73 20 22 22 0a 09 09 09 28 73 65 74 21 20 is ""....(set!
2940: 69 74 65 6d 2d 70 61 74 74 20 22 25 22 29 29 0a item-patt "%")).
2950: 09 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 .. ;; (print
2960: 22 74 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 "tests:match =>
2970: 70 61 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 patt-parts: " pa
2980: 74 74 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 tt-parts ", test
2990: 2d 70 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 -patt: " test-pa
29a0: 74 74 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a tt ", item-patt:
29b0: 20 22 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 " item-patt)...
29c0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 74 65 (if (and (te
29d0: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
29e0: 74 63 68 20 74 65 73 74 2d 70 61 74 74 20 74 65 tch test-patt te
29f0: 73 74 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 stname)....
2a00: 28 6f 72 20 28 6e 6f 74 20 69 74 65 6d 70 61 74 (or (not itempat
2a10: 68 29 0a 09 09 09 09 20 28 74 65 73 74 73 3a 67 h)..... (tests:g
2a20: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 28 lob-like-match (
2a30: 69 66 20 69 74 65 6d 2d 70 61 74 74 20 69 74 65 if item-patt ite
2a40: 6d 2d 70 61 74 74 20 22 22 29 20 69 74 65 6d 70 m-patt "") itemp
2a50: 61 74 68 29 29 29 0a 09 09 09 23 74 0a 09 09 09 ath)))....#t....
2a60: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
2a70: 09 09 09 20 20 20 20 23 66 0a 09 09 09 20 20 20 ... #f....
2a80: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
2a90: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 (cdr tal))))))))
2aa0: 29 29 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 )))..;; if itemp
2ab0: 61 74 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c ath is #f then l
2ac0: 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 ook only at the
2ad0: 74 65 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b testname part.;;
2ae0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
2af0: 6d 61 74 63 68 2d 3e 73 71 6c 71 72 79 20 70 61 match->sqlqry pa
2b00: 74 74 65 72 6e 73 29 0a 20 20 28 69 66 20 28 73 tterns). (if (s
2b10: 74 72 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 tring? patterns)
2b20: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 . (let ((pa
2b30: 74 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 tts (string-spli
2b40: 74 20 70 61 74 74 65 72 6e 73 20 22 2c 22 29 29 t patterns ","))
2b50: 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 )..(if (null? pa
2b60: 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 tts) ;;; no patt
2b70: 65 72 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 ern(s) means no
2b80: 6d 61 74 63 68 2c 20 77 65 20 77 69 6c 6c 20 64 match, we will d
2b90: 6f 20 6e 6f 20 71 75 65 72 79 0a 09 20 20 20 20 o no query..
2ba0: 23 66 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f #f.. (let loo
2bb0: 70 20 28 28 70 61 74 74 20 28 63 61 72 20 70 61 p ((patt (car pa
2bc0: 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 tts))... (
2bd0: 74 61 6c 20 20 28 63 64 72 20 70 61 74 74 73 29 tal (cdr patts)
2be0: 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 73 20 )... (res
2bf0: 20 27 28 29 29 29 0a 09 20 20 20 20 20 20 3b 3b '())).. ;;
2c00: 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 (print "loop: p
2c10: 61 74 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 att: " patt ", t
2c20: 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 al " tal)..
2c30: 20 28 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 (let* ((patt-pa
2c40: 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 rts (string-matc
2c50: 68 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c h (regexp "^([^\
2c60: 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 \/]*)(\\/(.*)|)$
2c70: 22 29 20 70 61 74 74 29 29 0a 09 09 20 20 20 20 ") patt))...
2c80: 20 28 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 (test-patt (ca
2c90: 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a dr patt-parts)).
2ca0: 09 09 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 .. (item-pat
2cb0: 74 20 20 28 63 61 64 64 64 72 20 70 61 74 74 2d t (cadddr patt-
2cc0: 70 61 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 parts))... (
2cd0: 74 65 73 74 2d 71 72 79 20 20 20 28 64 62 3a 70 test-qry (db:p
2ce0: 61 74 74 2d 3e 6c 69 6b 65 20 22 74 65 73 74 6e att->like "testn
2cf0: 61 6d 65 22 20 74 65 73 74 2d 70 61 74 74 29 29 ame" test-patt))
2d00: 0a 09 09 20 20 20 20 20 28 69 74 65 6d 2d 71 72 ... (item-qr
2d10: 79 20 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 y (db:patt->li
2d20: 6b 65 20 22 69 74 65 6d 5f 70 61 74 68 22 20 69 ke "item_path" i
2d30: 74 65 6d 2d 70 61 74 74 29 29 0a 09 09 20 20 20 tem-patt))...
2d40: 20 20 28 71 72 79 20 20 20 20 20 20 20 20 28 63 (qry (c
2d50: 6f 6e 63 20 22 28 22 20 74 65 73 74 2d 71 72 79 onc "(" test-qry
2d60: 20 22 20 41 4e 44 20 22 20 69 74 65 6d 2d 71 72 " AND " item-qr
2d70: 79 20 22 29 22 29 29 29 0a 09 09 3b 3b 20 28 70 y ")")))...;; (p
2d80: 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 63 rint "tests:matc
2d90: 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 3a h => patt-parts:
2da0: 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 22 2c " patt-parts ",
2db0: 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 74 65 test-patt: " te
2dc0: 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 6d 2d st-patt ", item-
2dd0: 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 patt: " item-pat
2de0: 74 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 t)...(if (null?
2df0: 74 61 6c 29 0a 09 09 20 20 20 20 28 73 74 72 69 tal)... (stri
2e00: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
2e10: 61 70 70 65 6e 64 20 28 72 65 76 65 72 73 65 20 append (reverse
2e20: 72 65 73 29 28 6c 69 73 74 20 71 72 79 29 29 20 res)(list qry))
2e30: 22 20 4f 52 20 22 29 0a 09 09 20 20 20 20 28 6c " OR ")... (l
2e40: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
2e50: 72 20 74 61 6c 29 28 63 6f 6e 73 20 71 72 79 20 r tal)(cons qry
2e60: 72 65 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 res))))))).
2e70: 20 23 66 29 29 0a 0a 3b 3b 20 43 68 65 63 6b 20 #f))..;; Check
2e80: 66 6f 72 20 77 61 69 76 65 72 20 65 6c 69 67 69 for waiver eligi
2e90: 62 69 6c 69 74 79 0a 3b 3b 0a 28 64 65 66 69 6e bility.;;.(defin
2ea0: 65 20 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 e (tests:check-w
2eb0: 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 aiver-eligibilit
2ec0: 79 20 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 y testdat prev-t
2ed0: 65 73 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 estdat). (let*
2ee0: 28 28 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ((test-registry
2ef0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
2f00: 29 29 0a 09 20 28 74 65 73 74 63 6f 6e 66 69 67 )).. (testconfig
2f10: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 (tests:get-tes
2f20: 74 63 6f 6e 66 69 67 20 28 64 62 3a 74 65 73 74 tconfig (db:test
2f30: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
2f40: 73 74 64 61 74 29 20 74 65 73 74 2d 72 65 67 69 stdat) test-regi
2f50: 73 74 72 79 20 23 66 29 29 0a 09 20 28 74 65 73 stry #f)).. (tes
2f60: 74 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 t-rundir ;; (sdb
2f70: 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 :qry 'passstr ..
2f80: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
2f90: 75 6e 64 69 72 20 74 65 73 74 64 61 74 29 29 20 undir testdat))
2fa0: 3b 3b 20 29 0a 09 20 28 70 72 65 76 2d 72 75 6e ;; ).. (prev-run
2fb0: 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 dir ;; (sdb:qry
2fc0: 27 70 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 'passstr .. (db
2fd0: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
2fe0: 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 29 20 prev-testdat))
2ff0: 3b 3b 20 29 0a 09 20 28 77 61 69 76 65 72 73 20 ;; ).. (waivers
3000: 20 20 20 20 28 69 66 20 74 65 73 74 63 6f 6e 66 (if testconf
3010: 69 67 20 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 ig (configf:sect
3020: 69 6f 6e 2d 76 61 72 73 20 74 65 73 74 63 6f 6e ion-vars testcon
3030: 66 69 67 20 22 77 61 69 76 65 72 73 22 29 20 27 fig "waivers") '
3040: 28 29 29 29 0a 09 20 28 77 61 69 76 65 72 2d 72 ())).. (waiver-r
3050: 78 20 20 20 28 72 65 67 65 78 70 20 22 5e 28 5c x (regexp "^(\
3060: 5c 53 2b 29 5c 5c 73 2b 28 2e 2a 29 24 22 29 29 \S+)\\s+(.*)$"))
3070: 0a 09 20 28 64 69 66 66 2d 72 75 6c 65 20 20 20 .. (diff-rule
3080: 22 64 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 "diff %file1% %f
3090: 69 6c 65 32 25 22 29 0a 09 20 28 6c 6f 67 70 72 ile2%").. (logpr
30a0: 6f 2d 72 75 6c 65 20 22 64 69 66 66 20 25 66 69 o-rule "diff %fi
30b0: 6c 65 31 25 20 25 66 69 6c 65 32 25 20 7c 20 6c le1% %file2% | l
30c0: 6f 67 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d ogpro %waivernam
30d0: 65 25 2e 6c 6f 67 70 72 6f 20 25 77 61 69 76 65 e%.logpro %waive
30e0: 72 6e 61 6d 65 25 2e 68 74 6d 6c 22 29 29 0a 20 rname%.html")).
30f0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
3100: 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 e-exists? test-r
3110: 75 6e 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a undir))..(begin.
3120: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
3130: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
3140: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
3150: 20 72 75 6e 20 64 69 72 65 63 74 6f 72 79 20 69 run directory i
3160: 73 20 67 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 s gone, cannot p
3170: 72 6f 70 61 67 61 74 65 20 77 61 69 76 65 72 22 ropagate waiver"
3180: 29 0a 09 20 20 23 66 29 0a 09 28 62 65 67 69 6e ).. #f)..(begin
3190: 0a 09 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 .. (push-direct
31a0: 6f 72 79 20 74 65 73 74 2d 72 75 6e 64 69 72 29 ory test-rundir)
31b0: 0a 09 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c .. (let ((resul
31c0: 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 t (if (null? wai
31d0: 76 65 72 73 29 0a 09 09 09 20 20 20 20 23 66 0a vers).... #f.
31e0: 09 09 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ... (let loop
31f0: 20 28 28 68 65 64 20 28 63 61 72 20 77 61 69 76 ((hed (car waiv
3200: 65 72 73 29 29 0a 09 09 09 09 20 20 20 20 20 20 ers)).....
3210: 20 28 74 61 6c 20 28 63 64 72 20 77 61 69 76 65 (tal (cdr waive
3220: 72 73 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 rs))).... (
3230: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3240: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3250: 20 22 49 4e 46 4f 3a 20 41 70 70 6c 79 69 6e 67 "INFO: Applying
3260: 20 77 61 69 76 65 72 20 72 75 6c 65 20 5c 22 22 waiver rule \""
3270: 20 68 65 64 20 22 5c 22 22 29 0a 09 09 09 20 20 hed "\"")....
3280: 20 20 20 20 28 6c 65 74 2a 20 28 28 77 61 69 76 (let* ((waiv
3290: 65 72 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 er (configf
32a0: 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 :lookup testconf
32b0: 69 67 20 22 77 61 69 76 65 72 73 22 20 68 65 64 ig "waivers" hed
32c0: 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 70 61 ))..... (wpa
32d0: 72 74 73 20 20 20 20 20 20 28 69 66 20 77 61 69 rts (if wai
32e0: 76 65 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 ver (string-matc
32f0: 68 20 77 61 69 76 65 72 2d 72 78 20 77 61 69 76 h waiver-rx waiv
3300: 65 72 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 er) #f)).....
3310: 20 20 28 77 61 69 76 65 72 2d 72 75 6c 65 20 28 (waiver-rule (
3320: 69 66 20 77 70 61 72 74 73 20 28 63 61 64 72 20 if wparts (cadr
3330: 77 70 61 72 74 73 29 20 20 23 66 29 29 0a 09 09 wparts) #f))...
3340: 09 09 20 20 20 20 20 28 77 61 69 76 65 72 2d 67 .. (waiver-g
3350: 6c 6f 62 20 28 69 66 20 77 70 61 72 74 73 20 28 lob (if wparts (
3360: 63 61 64 64 72 20 77 70 61 72 74 73 29 20 23 66 caddr wparts) #f
3370: 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 67 ))..... (log
3380: 70 72 6f 2d 66 69 6c 65 20 28 69 66 20 77 61 69 pro-file (if wai
3390: 76 65 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 ver.......
33a0: 28 6c 65 74 20 28 28 66 6e 61 6d 65 20 28 63 6f (let ((fname (co
33b0: 6e 63 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 nc hed ".logpro"
33c0: 29 29 29 0a 09 09 09 09 09 09 09 28 69 66 20 28 )))........(if (
33d0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 file-exists? fna
33e0: 6d 65 29 0a 09 09 09 09 09 09 09 20 20 20 20 66 me)........ f
33f0: 6e 61 6d 65 20 0a 09 09 09 09 09 09 09 20 20 20 name ........
3400: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 (begin........
3410: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3420: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3430: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f -port* "INFO: No
3440: 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 66 logpro file " f
3450: 6e 61 6d 65 20 22 20 66 61 6c 6c 69 6e 67 20 62 name " falling b
3460: 61 63 6b 20 74 6f 20 64 69 66 66 22 29 0a 09 09 ack to diff")...
3470: 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 29 ..... #f)))
3480: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 29 ....... #f)
3490: 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 69 66 )..... ;; if
34a0: 20 72 75 6c 65 20 62 79 20 6e 61 6d 65 20 6f 66 rule by name of
34b0: 20 77 61 69 76 65 72 2d 72 75 6c 65 20 69 73 20 waiver-rule is
34c0: 66 6f 75 6e 64 20 69 6e 20 74 65 73 74 63 6f 6e found in testcon
34d0: 66 69 67 20 2d 20 75 73 65 20 69 74 0a 09 09 09 fig - use it....
34e0: 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 69 66 . ;; else if
34f0: 20 77 61 69 76 65 72 6e 61 6d 65 2e 6c 6f 67 70 waivername.logp
3500: 72 6f 20 65 78 69 73 74 73 20 75 73 65 20 6c 6f ro exists use lo
3510: 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 09 20 20 gpro-rule.....
3520: 20 20 20 3b 3b 20 65 6c 73 65 20 64 65 66 61 75 ;; else defau
3530: 6c 74 20 74 6f 20 64 69 66 66 2d 72 75 6c 65 0a lt to diff-rule.
3540: 09 09 09 09 20 20 20 20 20 28 72 75 6c 65 2d 73 .... (rule-s
3550: 74 72 69 6e 67 20 28 6c 65 74 20 28 28 72 75 6c tring (let ((rul
3560: 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 e (configf:looku
3570: 70 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 p testconfig "wa
3580: 69 76 65 72 5f 72 75 6c 65 73 22 20 77 61 69 76 iver_rules" waiv
3590: 65 72 2d 72 75 6c 65 29 29 29 0a 09 09 09 09 09 er-rule)))......
35a0: 09 20 20 20 20 28 69 66 20 72 75 6c 65 0a 09 09 . (if rule...
35b0: 09 09 09 09 09 72 75 6c 65 0a 09 09 09 09 09 09 .....rule.......
35c0: 09 28 69 66 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 .(if logpro-file
35d0: 0a 09 09 09 09 09 09 09 20 20 20 20 6c 6f 67 70 ........ logp
35e0: 72 6f 2d 72 75 6c 65 0a 09 09 09 09 09 09 09 20 ro-rule........
35f0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 (begin.......
3600: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
3610: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
3620: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
3630: 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 No logpro file "
3640: 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 22 20 66 logpro-file " f
3650: 6f 75 6e 64 2c 20 75 73 69 6e 67 20 64 69 66 66 ound, using diff
3660: 20 72 75 6c 65 22 29 0a 09 09 09 09 09 09 09 20 rule")........
3670: 20 20 20 20 20 64 69 66 66 2d 72 75 6c 65 29 29 diff-rule))
3680: 29 29 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 )))..... ;;
3690: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
36a0: 74 65 20 22 25 66 69 6c 65 31 25 22 20 22 66 6f te "%file1%" "fo
36b0: 6f 66 6f 6f 2e 74 78 74 22 20 22 54 68 69 73 20 ofoo.txt" "This
36c0: 69 73 20 25 66 69 6c 65 31 25 20 61 6e 64 20 73 is %file1% and s
36d0: 6f 20 69 73 20 74 68 69 73 20 25 66 69 6c 65 31 o is this %file1
36e0: 25 2e 22 20 23 74 29 0a 09 09 09 09 20 20 20 20 %." #t).....
36f0: 20 28 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 (processed-cmd
3700: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
3710: 74 65 20 0a 09 09 09 09 09 09 20 20 20 20 20 22 te ....... "
3720: 25 66 69 6c 65 31 25 22 20 28 63 6f 6e 63 20 74 %file1%" (conc t
3730: 65 73 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 est-rundir "/" w
3740: 61 69 76 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 aiver-glob).....
3750: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 .. (string-s
3760: 75 62 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 ubstitute.......
3770: 20 20 20 20 20 20 22 25 66 69 6c 65 32 25 22 20 "%file2%"
3780: 28 63 6f 6e 63 20 70 72 65 76 2d 72 75 6e 64 69 (conc prev-rundi
3790: 72 20 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f r "/" waiver-glo
37a0: 62 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 b)....... (
37b0: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
37c0: 65 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 22 e....... "
37d0: 25 77 61 69 76 65 72 6e 61 6d 65 25 22 20 68 65 %waivername%" he
37e0: 64 20 72 75 6c 65 2d 73 74 72 69 6e 67 20 23 74 d rule-string #t
37f0: 29 20 23 74 29 20 23 74 29 29 0a 09 09 09 09 20 ) #t) #t)).....
3800: 20 20 20 20 28 72 65 73 20 20 20 20 20 20 20 20 (res
3810: 20 20 20 20 23 66 29 29 0a 09 09 09 09 28 64 65 #f)).....(de
3820: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3830: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3840: 49 4e 46 4f 3a 20 77 61 69 76 65 72 20 63 6f 6d INFO: waiver com
3850: 6d 61 6e 64 20 69 73 20 5c 22 22 20 70 72 6f 63 mand is \"" proc
3860: 65 73 73 65 64 2d 63 6d 64 20 22 5c 22 22 29 0a essed-cmd "\"").
3870: 09 09 09 09 28 69 66 20 28 65 71 3f 20 28 73 79 ....(if (eq? (sy
3880: 73 74 65 6d 20 70 72 6f 63 65 73 73 65 64 2d 63 stem processed-c
3890: 6d 64 29 20 30 29 0a 09 09 09 09 20 20 20 20 28 md) 0)..... (
38a0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
38b0: 09 09 09 09 23 74 0a 09 09 09 09 09 28 6c 6f 6f ....#t......(loo
38c0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
38d0: 74 61 6c 29 29 29 0a 09 09 09 09 20 20 20 20 23 tal)))..... #
38e0: 66 29 29 29 29 29 29 0a 09 20 20 20 20 28 70 6f f)))))).. (po
38f0: 70 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 p-directory)..
3900: 20 20 72 65 73 75 6c 74 29 29 29 29 29 0a 0a 28 result)))))..(
3910: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 define (tests:te
3920: 73 74 2d 66 6f 72 63 65 2d 73 74 61 74 65 2d 73 st-force-state-s
3930: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
3940: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
3950: 75 73 29 0a 20 20 28 72 6d 74 3a 74 65 73 74 2d us). (rmt:test-
3960: 73 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 set-status-state
3970: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
3980: 73 74 61 74 75 73 20 73 74 61 74 65 20 23 66 29 status state #f)
3990: 0a 20 20 3b 3b 20 28 72 6d 74 3a 72 6f 6c 6c 2d . ;; (rmt:roll-
39a0: 75 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 up-pass-fail-cou
39b0: 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nts run-id test-
39c0: 6e 61 6d 65 20 69 74 65 6d 0a 20 20 28 6d 74 3a name item. (mt:
39d0: 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 process-triggers
39e0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
39f0: 73 74 61 74 65 20 73 74 61 74 75 73 29 29 0a 0a state status))..
3a00: 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 63 20 74 68 ;; Do not rpc th
3a10: 69 73 20 6f 6e 65 2c 20 64 6f 20 74 68 65 20 75 is one, do the u
3a20: 6e 64 65 72 6c 79 69 6e 67 20 63 61 6c 6c 73 21 nderlying calls!
3a30: 21 21 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 !!.(define (test
3a40: 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 s:test-set-statu
3a50: 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 s! run-id test-i
3a60: 64 20 73 74 61 74 65 20 73 74 61 74 75 73 20 63 d state status c
3a70: 6f 6d 6d 65 6e 74 20 64 61 74 20 23 21 6b 65 79 omment dat #!key
3a80: 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 (work-area #f))
3a90: 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 61 6c 2d . (let* ((real-
3aa0: 73 74 61 74 75 73 20 73 74 61 74 75 73 29 0a 09 status status)..
3ab0: 20 28 6f 74 68 65 72 64 61 74 20 20 20 20 28 69 (otherdat (i
3ac0: 66 20 64 61 74 20 64 61 74 20 28 6d 61 6b 65 2d f dat dat (make-
3ad0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 hash-table)))..
3ae0: 28 74 65 73 74 64 61 74 20 20 20 20 20 28 72 6d (testdat (rm
3af0: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
3b00: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
3b10: 74 2d 69 64 29 29 0a 09 20 28 74 65 73 74 2d 6e t-id)).. (test-n
3b20: 61 6d 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 ame (db:test-g
3b30: 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 et-testname tes
3b40: 74 64 61 74 29 29 0a 09 20 28 69 74 65 6d 2d 70 tdat)).. (item-p
3b50: 61 74 68 20 20 20 28 64 62 3a 74 65 73 74 2d 67 ath (db:test-g
3b60: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
3b70: 74 64 61 74 29 29 0a 09 20 3b 3b 20 62 65 66 6f tdat)).. ;; befo
3b80: 72 65 20 70 72 6f 63 65 65 64 69 6e 67 20 77 65 re proceeding we
3b90: 20 6d 75 73 74 20 66 69 6e 64 20 6f 75 74 20 69 must find out i
3ba0: 66 20 74 68 65 20 70 72 65 76 69 6f 75 73 20 74 f the previous t
3bb0: 65 73 74 20 28 77 68 65 72 65 20 61 6c 6c 20 6b est (where all k
3bc0: 65 79 73 20 6d 61 74 63 68 65 64 20 65 78 63 65 eys matched exce
3bd0: 70 74 20 72 75 6e 6e 61 6d 65 29 0a 09 20 3b 3b pt runname).. ;;
3be0: 20 77 61 73 20 57 41 49 56 45 44 20 69 66 20 74 was WAIVED if t
3bf0: 68 69 73 20 74 65 73 74 20 69 73 20 46 41 49 4c his test is FAIL
3c00: 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 3a 0a 09 20 ... ;; NOTES:..
3c10: 3b 3b 20 20 31 2e 20 49 73 20 74 68 65 20 63 61 ;; 1. Is the ca
3c20: 6c 6c 20 74 6f 20 74 65 73 74 3a 67 65 74 2d 70 ll to test:get-p
3c30: 72 65 76 69 6f 75 73 2d 72 75 6e 2d 72 65 63 6f revious-run-reco
3c40: 72 64 20 72 65 6d 6f 74 69 66 69 65 64 3f 0a 09 rd remotified?..
3c50: 20 3b 3b 20 20 32 2e 20 41 64 64 20 74 65 73 74 ;; 2. Add test
3c60: 20 66 6f 72 20 74 65 73 74 63 6f 6e 66 69 67 20 for testconfig
3c70: 77 61 69 76 65 72 20 70 72 6f 70 61 67 61 74 69 waiver propagati
3c80: 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 65 72 65 0a on control here.
3c90: 09 20 3b 3b 0a 09 20 28 70 72 65 76 2d 74 65 73 . ;;.. (prev-tes
3ca0: 74 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 t (if (equal?
3cb0: 73 74 61 74 75 73 20 22 46 41 49 4c 22 29 0a 09 status "FAIL")..
3cc0: 09 09 20 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 .. (rmt:get-pre
3cd0: 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 vious-test-run-r
3ce0: 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 65 73 ecord run-id tes
3cf0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
3d00: 29 0a 09 09 09 20 20 23 66 29 29 0a 09 20 28 77 ).... #f)).. (w
3d10: 61 69 76 65 64 20 20 20 28 69 66 20 70 72 65 76 aived (if prev
3d20: 2d 74 65 73 74 0a 09 09 20 20 20 20 20 20 20 28 -test... (
3d30: 69 66 20 70 72 65 76 2d 74 65 73 74 20 3b 3b 20 if prev-test ;;
3d40: 74 72 75 65 20 69 66 20 77 65 20 66 6f 75 6e 64 true if we found
3d50: 20 61 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 a previous test
3d60: 20 69 6e 20 74 68 69 73 20 72 75 6e 20 73 65 72 in this run ser
3d70: 69 65 73 0a 09 09 09 20 20 20 28 6c 65 74 20 28 ies.... (let (
3d80: 28 70 72 65 76 2d 73 74 61 74 75 73 20 20 28 64 (prev-status (d
3d90: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
3da0: 73 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 s prev-test))..
3db0: 09 09 09 20 28 70 72 65 76 2d 73 74 61 74 65 20 ... (prev-state
3dc0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
3dd0: 74 61 74 65 20 20 20 70 72 65 76 2d 74 65 73 74 tate prev-test
3de0: 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d 63 6f ))..... (prev-co
3df0: 6d 6d 65 6e 74 20 28 64 62 3a 74 65 73 74 2d 67 mment (db:test-g
3e00: 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 72 65 76 2d et-comment prev-
3e10: 74 65 73 74 29 29 29 0a 09 09 09 20 20 20 20 20 test)))....
3e20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
3e30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3e40: 2a 20 22 70 72 65 76 2d 73 74 61 74 75 73 20 22 * "prev-status "
3e50: 20 70 72 65 76 2d 73 74 61 74 75 73 20 22 2c 20 prev-status ",
3e60: 70 72 65 76 2d 73 74 61 74 65 20 22 20 70 72 65 prev-state " pre
3e70: 76 2d 73 74 61 74 65 20 22 2c 20 70 72 65 76 2d v-state ", prev-
3e80: 63 6f 6d 6d 65 6e 74 20 22 20 70 72 65 76 2d 63 comment " prev-c
3e90: 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 20 20 20 20 omment)....
3ea0: 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f (if (and (equal?
3eb0: 20 70 72 65 76 2d 73 74 61 74 65 20 20 22 43 4f prev-state "CO
3ec0: 4d 50 4c 45 54 45 44 22 29 0a 09 09 09 09 20 20 MPLETED").....
3ed0: 20 20 20 20 28 65 71 75 61 6c 3f 20 70 72 65 76 (equal? prev
3ee0: 2d 73 74 61 74 75 73 20 22 57 41 49 56 45 44 22 -status "WAIVED"
3ef0: 29 29 0a 09 09 09 09 20 28 69 66 20 63 6f 6d 6d ))..... (if comm
3f00: 65 6e 74 0a 09 09 09 09 20 20 20 20 20 63 6f 6d ent..... com
3f10: 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 20 70 72 ment..... pr
3f20: 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 3b 3b 20 77 ev-comment) ;; w
3f30: 61 69 76 65 64 20 69 73 20 65 69 74 68 65 72 20 aived is either
3f40: 74 68 65 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 23 the comment or #
3f50: 66 0a 09 09 09 09 20 23 66 29 29 0a 09 09 09 20 f..... #f))....
3f60: 20 20 23 66 29 0a 09 09 20 20 20 20 20 20 20 23 #f)... #
3f70: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e f))). (if (an
3f80: 64 20 77 61 69 76 65 64 20 0a 09 20 20 20 20 20 d waived ..
3f90: 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 (tests:check-wai
3fa0: 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 ver-eligibility
3fb0: 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 65 73 testdat prev-tes
3fc0: 74 29 29 0a 09 28 73 65 74 21 20 72 65 61 6c 2d t))..(set! real-
3fd0: 73 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 status "WAIVED")
3fe0: 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
3ff0: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
4000: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 61 6c 2d 73 og-port* "real-s
4010: 74 61 74 75 73 20 22 20 72 65 61 6c 2d 73 74 61 tatus " real-sta
4020: 74 75 73 20 22 2c 20 77 61 69 76 65 64 20 22 20 tus ", waived "
4030: 77 61 69 76 65 64 20 22 2c 20 73 74 61 74 75 73 waived ", status
4040: 20 22 20 73 74 61 74 75 73 29 0a 0a 20 20 20 20 " status)..
4050: 3b 3b 20 75 70 64 61 74 65 20 74 68 65 20 70 72 ;; update the pr
4060: 69 6d 61 72 79 20 72 65 63 6f 72 64 20 49 46 20 imary record IF
4070: 73 74 61 74 65 20 41 4e 44 20 73 74 61 74 75 73 state AND status
4080: 20 61 72 65 20 64 65 66 69 6e 65 64 0a 20 20 20 are defined.
4090: 20 28 69 66 20 28 61 6e 64 20 73 74 61 74 65 20 (if (and state
40a0: 73 74 61 74 75 73 29 0a 09 28 62 65 67 69 6e 0a status)..(begin.
40b0: 09 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 . (rmt:test-set
40c0: 2d 73 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 -status-state ru
40d0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 72 65 61 n-id test-id rea
40e0: 6c 2d 73 74 61 74 75 73 20 73 74 61 74 65 20 28 l-status state (
40f0: 69 66 20 77 61 69 76 65 64 20 77 61 69 76 65 64 if waived waived
4100: 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 3b 3b comment)).. ;;
4110: 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d 74 72 69 (mt:process-tri
4120: 67 67 65 72 73 20 72 75 6e 2d 69 64 20 74 65 73 ggers run-id tes
4130: 74 2d 69 64 20 73 74 61 74 65 20 72 65 61 6c 2d t-id state real-
4140: 73 74 61 74 75 73 29 20 3b 3b 20 74 72 69 67 67 status) ;; trigg
4150: 65 72 73 20 61 72 65 20 63 61 6c 6c 65 64 20 69 ers are called i
4160: 6e 20 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 n test-set-statu
4170: 73 2d 73 74 61 74 65 0a 09 20 20 29 29 0a 20 20 s-state.. )).
4180: 20 20 0a 20 20 20 20 3b 3b 20 69 66 20 73 74 61 . ;; if sta
4190: 74 75 73 20 69 73 20 22 41 55 54 4f 22 20 74 68 tus is "AUTO" th
41a0: 65 6e 20 63 61 6c 6c 20 72 6f 6c 6c 75 70 20 28 en call rollup (
41b0: 6e 6f 74 65 2c 20 74 68 69 73 20 6f 6e 65 20 6d note, this one m
41c0: 6f 64 69 66 69 65 73 20 64 61 74 61 20 69 6e 20 odifies data in
41d0: 74 65 73 74 0a 20 20 20 20 3b 3b 20 72 75 6e 20 test. ;; run
41e0: 61 72 65 61 2c 20 69 74 20 64 6f 65 73 20 72 65 area, it does re
41f0: 6d 6f 74 65 20 63 61 6c 6c 73 20 75 6e 64 65 72 mote calls under
4200: 20 74 68 65 20 68 6f 6f 64 2e 0a 20 20 20 20 3b the hood.. ;
4210: 3b 20 28 69 66 20 28 61 6e 64 20 74 65 73 74 2d ; (if (and test-
4220: 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 20 id state status
4230: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
4240: 41 55 54 4f 22 29 29 20 0a 20 20 20 20 3b 3b 20 AUTO")) . ;;
4250: 09 28 72 6d 74 3a 74 65 73 74 2d 64 61 74 61 2d .(rmt:test-data-
4260: 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 74 65 rollup run-id te
4270: 73 74 2d 69 64 20 73 74 61 74 75 73 29 29 0a 0a st-id status))..
4280: 20 20 20 20 3b 3b 20 61 64 64 20 6d 65 74 61 64 ;; add metad
4290: 61 74 61 20 28 6e 65 65 64 20 74 6f 20 64 6f 20 ata (need to do
42a0: 74 68 69 73 20 77 61 79 20 74 6f 20 61 76 6f 69 this way to avoi
42b0: 64 20 53 51 4c 20 69 6e 6a 65 63 74 69 6f 6e 20 d SQL injection
42c0: 69 73 73 75 65 73 29 0a 0a 20 20 20 20 3b 3b 20 issues).. ;;
42d0: 3a 66 69 72 73 74 5f 65 72 72 0a 20 20 20 20 3b :first_err. ;
42e0: 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 ; (let ((val (ha
42f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4300: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
4310: 66 69 72 73 74 5f 65 72 72 22 20 23 66 29 29 29 first_err" #f)))
4320: 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 76 61 . ;; (if va
4330: 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 l. ;; (
4340: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
4350: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
4360: 20 53 45 54 20 66 69 72 73 74 5f 65 72 72 3d 3f SET first_err=?
4370: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
4380: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
4390: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 ND item_path=?;"
43a0: 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 val run-id test
43b0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
43c0: 29 29 0a 20 20 20 20 3b 3b 20 0a 20 20 20 20 3b )). ;; . ;
43d0: 3b 20 3b 3b 20 3a 66 69 72 73 74 5f 77 61 72 6e ; ;; :first_warn
43e0: 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 . ;; (let ((v
43f0: 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 al (hash-table-r
4400: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
4410: 64 61 74 20 22 3a 66 69 72 73 74 5f 77 61 72 6e dat ":first_warn
4420: 22 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 " #f))). ;;
4430: 20 28 69 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 (if val. ;;
4440: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 (sqlite3:e
4450: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
4460: 45 20 74 65 73 74 73 20 53 45 54 20 66 69 72 73 E tests SET firs
4470: 74 5f 77 61 72 6e 3d 3f 20 57 48 45 52 45 20 72 t_warn=? WHERE r
4480: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 un_id=? AND test
4490: 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f name=? AND item_
44a0: 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e path=?;" val run
44b0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
44c0: 65 6d 2d 70 61 74 68 29 29 29 0a 0a 20 20 20 20 em-path)))..
44d0: 28 6c 65 74 20 28 28 63 61 74 65 67 6f 72 79 20 (let ((category
44e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
44f0: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
4500: 20 22 3a 63 61 74 65 67 6f 72 79 22 20 22 22 29 ":category" "")
4510: 29 0a 09 20 20 28 76 61 72 69 61 62 6c 65 20 28 ).. (variable (
4520: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4530: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
4540: 22 3a 76 61 72 69 61 62 6c 65 22 20 22 22 29 29 ":variable" ""))
4550: 0a 09 20 20 28 76 61 6c 75 65 20 20 20 20 28 68 .. (value (h
4560: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4570: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4580: 3a 76 61 6c 75 65 22 20 20 20 20 23 66 29 29 0a :value" #f)).
4590: 09 20 20 28 65 78 70 65 63 74 65 64 20 28 68 61 . (expected (ha
45a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
45b0: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
45c0: 65 78 70 65 63 74 65 64 22 20 23 66 29 29 0a 09 expected" #f))..
45d0: 20 20 28 74 6f 6c 20 20 20 20 20 20 28 68 61 73 (tol (has
45e0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
45f0: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 ult otherdat ":t
4600: 6f 6c 22 20 20 20 20 20 20 23 66 29 29 0a 09 20 ol" #f))..
4610: 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 68 (units (hash
4620: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4630: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 6e lt otherdat ":un
4640: 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 20 its" ""))..
4650: 28 74 79 70 65 20 20 20 20 20 28 68 61 73 68 2d (type (hash-
4660: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4670: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 70 t otherdat ":typ
4680: 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 28 e" "")).. (
4690: 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d 74 dcomment (hash-t
46a0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
46b0: 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d 6d otherdat ":comm
46c0: 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 20 ent" ""))).
46d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
46e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
46f0: 72 74 2a 20 0a 09 09 20 20 20 22 63 61 74 65 67 rt* ... "categ
4700: 6f 72 79 3a 20 22 20 63 61 74 65 67 6f 72 79 20 ory: " category
4710: 22 2c 20 76 61 72 69 61 62 6c 65 3a 20 22 20 76 ", variable: " v
4720: 61 72 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 65 ariable ", value
4730: 3a 20 22 20 76 61 6c 75 65 0a 09 09 20 20 20 22 : " value... "
4740: 2c 20 65 78 70 65 63 74 65 64 3a 20 22 20 65 78 , expected: " ex
4750: 70 65 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 22 pected ", tol: "
4760: 20 74 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 22 tol ", units: "
4770: 20 75 6e 69 74 73 29 0a 20 20 20 20 20 20 28 69 units). (i
4780: 66 20 28 61 6e 64 20 76 61 6c 75 65 20 65 78 70 f (and value exp
4790: 65 63 74 65 64 20 74 6f 6c 29 20 3b 3b 20 61 6c ected tol) ;; al
47a0: 6c 20 74 68 72 65 65 20 72 65 71 75 69 72 65 64 l three required
47b0: 0a 09 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 .. (let ((dat (
47c0: 63 6f 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c conc category ",
47d0: 22 0a 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 ".... variable
47e0: 20 22 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 ",".... value
47f0: 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 ",".... ex
4800: 70 65 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 pected ","....
4810: 20 74 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 tol ","...
4820: 09 20 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 . units ","
4830: 0a 09 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 .... dcomment
4840: 22 2c 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f ",," ;; extra co
4850: 6d 6d 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 mma for status..
4860: 09 09 20 20 20 74 79 70 65 20 20 20 20 20 29 29 .. type ))
4870: 29 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 ).. ;; This w
4880: 61 73 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 as run remote, d
4890: 6f 6e 27 74 20 74 68 69 6e 6b 20 74 68 61 74 20 on't think that
48a0: 6d 61 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 72 makes sense. Per
48b0: 68 61 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 haps not, but th
48c0: 61 74 20 69 73 20 74 68 65 20 65 61 73 69 65 73 at is the easies
48d0: 74 20 70 61 74 68 20 66 6f 72 20 74 68 65 20 6d t path for the m
48e0: 6f 6d 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 oment... (rmt
48f0: 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 :csv->test-data
4900: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 run-id test-id..
4910: 09 09 09 64 61 74 29 29 29 29 0a 20 20 20 20 20 ...dat)))).
4920: 20 0a 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f . ;; need to
4930: 20 75 70 64 61 74 65 20 74 68 65 20 74 6f 70 20 update the top
4940: 74 65 73 74 20 72 65 63 6f 72 64 20 69 66 20 50 test record if P
4950: 41 53 53 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 ASS or FAIL and
4960: 74 68 69 73 20 69 73 20 61 20 73 75 62 74 65 73 this is a subtes
4970: 74 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 t. (if (not (
4980: 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 equal? item-path
4990: 20 22 22 29 29 0a 09 28 72 6d 74 3a 72 6f 6c 6c ""))..(rmt:roll
49a0: 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f -up-pass-fail-co
49b0: 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 unts run-id test
49c0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
49d0: 73 74 61 74 65 20 73 74 61 74 75 73 20 23 66 29 state status #f)
49e0: 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 ).. (if (or (
49f0: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d and (string? com
4a00: 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 ment)... (string
4a10: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
4a20: 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 \\S+") comment))
4a30: 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 .. waived)..(
4a40: 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 20 77 let ((cmt (if w
4a50: 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d aived waived com
4a60: 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 3a ment))).. (rmt:
4a70: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 general-call 'se
4a80: 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 t-test-comment r
4a90: 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 2d 69 un-id cmt test-i
4aa0: 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 d)))))..(define
4ab0: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
4ac0: 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 toplog! run-id t
4ad0: 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a est-name logf) .
4ae0: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
4af0: 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 74 2d all 'tests:test-
4b00: 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 set-toplog run-i
4b10: 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 d logf run-id te
4b20: 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 st-name))..(defi
4b30: 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 ne (tests:summar
4b40: 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 ize-items run-id
4b50: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 test-id test-na
4b60: 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 me force). ;; i
4b70: 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 6e f not force then
4b80: 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 68 65 only update the
4b90: 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f record if one o
4ba0: 66 20 74 68 65 73 65 20 69 73 20 74 72 75 65 3a f these is true:
4bb0: 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 . ;; 1. logf
4bc0: 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f is "log/final.lo
4bd0: 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 g. ;; 2. logf
4be0: 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 74 70 is same as outp
4bf0: 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 utfilename. (le
4c00: 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c 65 6e t* ((outputfilen
4c10: 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 ame (conc "megat
4c20: 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 est-rollup-" tes
4c30: 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 t-name ".html"))
4c40: 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 20 20 .. (orig-dir
4c50: 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 (current-dire
4c60: 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d ctory)).. (logf-
4c70: 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 info (rmt:t
4c80: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
4c90: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
4ca0: 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 -name)).. (logf
4cb0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f (if lo
4cc0: 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f gf-info (cadr lo
4cd0: 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 gf-info) #f))..
4ce0: 28 70 61 74 68 20 20 20 20 20 20 20 20 20 20 20 (path
4cf0: 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 (if logf-info (c
4d00: 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 ar logf-info) #
4d10: 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 f))). ;; This
4d20: 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 68 65 query finds the
4d30: 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e 67 65 path and change
4d40: 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 s the directory
4d50: 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 74 65 to it for the te
4d60: 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 st. (if (and
4d70: 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 (string? path)..
4d80: 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f (directory?
4d90: 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 path)) ;; can g
4da0: 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 65 72 et #f here under
4db0: 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 some wierd cond
4dc0: 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b itions. why, unk
4dd0: 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e nown .....(begin
4de0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
4df0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
4e00: 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 port* "Found pat
4e10: 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 28 63 h: " path).. (c
4e20: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
4e30: 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 path))..;; (set!
4e40: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
4e50: 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f (conc path "/" o
4e60: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 utputfilename)))
4e70: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
4e80: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
4e90: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 log-port* "summa
4ea0: 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 rize-items for r
4eb0: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
4ec0: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
4ed0: 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 st-name ", no su
4ee0: 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 ch path: " path)
4ef0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
4f00: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
4f10: 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 g-port* "summari
4f20: 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 6c 6f ze-items with lo
4f30: 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 gf " logf ", out
4f40: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 putfilename " ou
4f50: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 tputfilename " a
4f60: 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 63 65 nd force " force
4f70: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 ). (if (or (e
4f80: 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 qual? logf "logs
4f90: 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 /final.log")..
4fa0: 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f (equal? logf o
4fb0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
4fc0: 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 force)..(let
4fd0: 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 ((my-start-time
4fe0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
4ff0: 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b s)).. (lock
5000: 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 f (conc
5010: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
5020: 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 .lock"))).. (le
5030: 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f t loop ((have-lo
5040: 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 ck (common:simp
5050: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
5060: 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 20 68 kf))).. (if h
5070: 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 ave-lock...(let
5080: 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 69 67 ((script (config
5090: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
50a0: 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 dat* "testrollup
50b0: 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 " test-name)))..
50c0: 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 . (print "Obtai
50d0: 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f ned lock for " o
50e0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
50f0: 09 20 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d . (rmt:roll-up-
5100: 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 pass-fail-counts
5110: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5120: 65 20 22 22 20 23 66 20 23 66 20 23 66 29 0a 09 e "" #f #f #f)..
5130: 09 20 20 3b 3b 20 28 72 6d 74 3a 74 65 73 74 2d . ;; (rmt:test-
5140: 73 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 set-status-state
5150: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5160: 65 20 23 66 20 23 66 20 23 66 29 20 3b 3b 20 28 e #f #f #f) ;; (
5170: 72 6d 74 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 rmt:top-test-set
5180: 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 -per-pf-counts r
5190: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
51a0: 0a 09 09 20 20 28 69 66 20 73 63 72 69 70 74 0a ... (if script.
51b0: 09 09 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 .. (system
51c0: 28 63 6f 6e 63 20 73 63 72 69 70 74 20 22 20 3e (conc script " >
51d0: 20 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d " outputfilenam
51e0: 65 20 22 20 26 20 22 29 29 0a 09 09 20 20 20 20 e " & "))...
51f0: 20 20 28 74 65 73 74 73 3a 67 65 6e 65 72 61 74 (tests:generat
5200: 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 2d 66 e-html-summary-f
5210: 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 65 73 74 or-iterated-test
5220: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
5230: 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 test-name output
5240: 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 20 20 28 filename))... (
5250: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
5260: 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 le-release-lock
5270: 6c 6f 63 6b 66 29 0a 09 09 20 20 28 63 68 61 6e lockf)... (chan
5280: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 6f 72 69 ge-directory ori
5290: 67 2d 64 69 72 29 0a 09 09 20 20 3b 3b 20 4e 42 g-dir)... ;; NB
52a0: 2f 2f 20 74 65 73 74 73 3a 74 65 73 74 2d 73 65 // tests:test-se
52b0: 74 2d 74 6f 70 6c 6f 67 21 20 69 73 20 72 65 6d t-toplog! is rem
52c0: 6f 74 65 20 69 6e 74 65 72 6e 61 6c 2e 2e 2e 0a ote internal....
52d0: 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d .. (tests:test-
52e0: 73 65 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e 2d set-toplog! run-
52f0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 id test-name out
5300: 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 putfilename))...
5310: 3b 3b 20 64 69 64 6e 27 74 20 67 65 74 20 74 68 ;; didn't get th
5320: 65 20 6c 6f 63 6b 2c 20 63 68 65 63 6b 20 74 6f e lock, check to
5330: 20 73 65 65 20 69 66 20 63 75 72 72 65 6e 74 20 see if current
5340: 75 70 64 61 74 65 20 73 74 61 72 74 65 64 20 6c update started l
5350: 61 74 65 72 20 74 68 61 6e 20 74 68 69 73 20 0a ater than this .
5360: 09 09 3b 3b 20 75 70 64 61 74 65 2c 20 69 66 20 ..;; update, if
5370: 73 6f 20 77 65 20 63 61 6e 20 65 78 69 74 20 77 so we can exit w
5380: 69 74 68 6f 75 74 20 64 6f 69 6e 67 20 61 6e 79 ithout doing any
5390: 20 77 6f 72 6b 0a 09 09 28 69 66 20 28 3e 20 6d work...(if (> m
53a0: 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 66 69 y-start-time (fi
53b0: 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d le-modification-
53c0: 74 69 6d 65 20 6c 6f 63 6b 66 29 29 0a 09 09 20 time lockf))...
53d0: 20 20 20 3b 3b 20 77 65 20 73 74 61 72 74 65 64 ;; we started
53e0: 20 73 69 6e 63 65 20 63 75 72 72 65 6e 74 20 72 since current r
53f0: 65 2d 67 65 6e 20 69 6e 20 66 6c 69 67 68 74 2c e-gen in flight,
5400: 20 64 65 6c 61 79 20 61 20 6c 69 74 74 6c 65 20 delay a little
5410: 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a 09 09 and try again...
5420: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
5430: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5440: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
5450: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 61 69 74 69 log-port* "Waiti
5460: 6e 67 20 74 6f 20 75 70 64 61 74 65 20 22 20 6f ng to update " o
5470: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 2c utputfilename ",
5480: 20 61 6e 6f 74 68 65 72 20 74 65 73 74 20 63 75 another test cu
5490: 72 72 65 6e 74 6c 79 20 75 70 64 61 74 69 6e 67 rrently updating
54a0: 20 69 74 22 29 0a 09 09 20 20 20 20 20 20 28 74 it")... (t
54b0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 hread-sleep! (+
54c0: 35 20 28 72 61 6e 64 6f 6d 20 35 29 29 29 20 3b 5 (random 5))) ;
54d0: 3b 20 64 65 6c 61 79 20 62 65 74 77 65 65 6e 20 ; delay between
54e0: 35 20 61 6e 64 20 31 30 20 73 65 63 6f 6e 64 73 5 and 10 seconds
54f0: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
5500: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
5510: 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 29 29 le-lock lockf)))
5520: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
5530: 20 28 74 65 73 74 73 3a 67 65 6e 65 72 61 74 65 (tests:generate
5540: 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 2d 66 6f -html-summary-fo
5550: 72 2d 69 74 65 72 61 74 65 64 2d 74 65 73 74 20 r-iterated-test
5560: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 74 run-id test-id t
5570: 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 est-name outputf
5580: 69 6c 65 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 ilename). (let
5590: 28 28 63 6f 75 6e 74 73 20 20 20 20 20 20 20 20 ((counts
55a0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
55b0: 2d 74 61 62 6c 65 29 29 0a 09 28 73 74 61 74 65 -table))..(state
55c0: 63 6f 75 6e 74 73 20 20 20 20 20 20 20 20 20 28 counts (
55d0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
55e0: 29 0a 09 28 6f 75 74 74 78 74 20 20 20 20 20 20 )..(outtxt
55f0: 20 20 20 20 20 20 20 20 22 22 29 0a 09 28 74 6f "")..(to
5600: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
5610: 20 20 30 29 0a 09 28 74 65 73 74 64 61 74 20 20 0)..(testdat
5620: 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a (rmt:
5630: 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 test-get-records
5640: 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 -for-index-file
5650: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5660: 29 29 29 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 ))). (with-ou
5670: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 6f 75 74 tput-to-file out
5680: 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 20 20 putfilename.
5690: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 73 (lambda ()..(s
56a0: 65 74 21 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 et! outtxt (conc
56b0: 20 6f 75 74 74 78 74 20 22 3c 68 74 6d 6c 3e 3c outtxt "<html><
56c0: 74 69 74 6c 65 3e 53 75 6d 6d 61 72 79 3a 20 22 title>Summary: "
56d0: 20 74 65 73 74 2d 6e 61 6d 65 20 0a 09 09 09 20 test-name ....
56e0: 20 20 22 3c 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 "</title><body
56f0: 3e 3c 68 32 3e 53 75 6d 6d 61 72 79 20 66 6f 72 ><h2>Summary for
5700: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 3c 2f " test-name "</
5710: 68 32 3e 22 29 29 0a 09 28 66 6f 72 2d 65 61 63 h2>"))..(for-eac
5720: 68 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 65 73 h.. (lambda (tes
5730: 74 72 65 63 6f 72 64 29 0a 09 20 20 20 28 6c 65 trecord).. (le
5740: 74 20 28 28 69 64 20 20 20 20 20 20 20 20 20 20 t ((id
5750: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
5760: 65 73 74 72 65 63 6f 72 64 20 30 29 29 0a 09 09 estrecord 0))...
5770: 20 28 69 74 65 6d 70 61 74 68 20 20 20 20 20 20 (itempath
5780: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
5790: 74 72 65 63 6f 72 64 20 31 29 29 0a 09 09 20 28 trecord 1))... (
57a0: 73 74 61 74 65 20 20 20 20 20 20 20 20 20 20 28 state (
57b0: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 vector-ref testr
57c0: 65 63 6f 72 64 20 32 29 29 0a 09 09 20 28 73 74 ecord 2))... (st
57d0: 61 74 75 73 20 20 20 20 20 20 20 20 20 28 76 65 atus (ve
57e0: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 ctor-ref testrec
57f0: 6f 72 64 20 33 29 29 0a 09 09 20 28 72 75 6e 5f ord 3))... (run_
5800: 64 75 72 61 74 69 6f 6e 20 20 20 28 76 65 63 74 duration (vect
5810: 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 or-ref testrecor
5820: 64 20 34 29 29 0a 09 09 20 28 6c 6f 67 66 20 20 d 4))... (logf
5830: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
5840: 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 -ref testrecord
5850: 35 29 29 0a 09 09 20 28 63 6f 6d 6d 65 6e 74 20 5))... (comment
5860: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
5870: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 36 29 ef testrecord 6)
5880: 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 )).. (hash-t
5890: 61 62 6c 65 2d 73 65 74 21 20 63 6f 75 6e 74 73 able-set! counts
58a0: 20 73 74 61 74 75 73 20 28 2b 20 31 20 28 68 61 status (+ 1 (ha
58b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
58c0: 61 75 6c 74 20 63 6f 75 6e 74 73 20 73 74 61 74 ault counts stat
58d0: 75 73 20 30 29 29 29 0a 09 20 20 20 20 20 28 68 us 0))).. (h
58e0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
58f0: 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 tatecounts state
5900: 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c (+ 1 (hash-tabl
5910: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 74 e-ref/default st
5920: 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 20 atecounts state
5930: 30 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 0))).. (set!
5940: 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 outtxt (conc ou
5950: 74 74 78 74 20 22 3c 74 72 3e 22 0a 09 09 09 09 ttxt "<tr>".....
5960: 3b 3b 20 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d ;; "<td><a href=
5970: 5c 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f 22 \"" itempath "/"
5980: 20 6c 6f 67 66 20 22 5c 22 3e 20 22 20 69 74 65 logf "\"> " ite
5990: 6d 70 61 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e mpath "</a></td>
59a0: 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c 61 20 68 " ....."<td><a h
59b0: 72 65 66 3d 5c 22 22 20 69 74 65 6d 70 61 74 68 ref=\"" itempath
59c0: 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e "/test-summary.
59d0: 68 74 6d 6c 5c 22 3e 20 22 20 69 74 65 6d 70 61 html\"> " itempa
59e0: 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a th "</a></td>" .
59f0: 09 09 09 09 22 3c 74 64 3e 22 20 73 74 61 74 65 ...."<td>" state
5a00: 20 20 20 20 22 3c 2f 74 64 3e 22 20 0a 09 09 09 "</td>" ....
5a10: 09 22 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f ."<td><font colo
5a20: 72 3d 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d r=" (common:get-
5a30: 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 color-from-statu
5a40: 73 20 73 74 61 74 75 73 29 0a 09 09 09 09 22 3e s status).....">
5a50: 22 20 20 20 73 74 61 74 75 73 20 20 20 22 3c 2f " status "</
5a60: 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 09 09 09 font></td>".....
5a70: 22 3c 74 64 3e 22 20 28 69 66 20 28 65 71 75 61 "<td>" (if (equa
5a80: 6c 3f 20 63 6f 6d 6d 65 6e 74 20 22 22 29 0a 09 l? comment "")..
5a90: 09 09 09 09 20 20 20 22 26 6e 62 73 70 3b 22 0a .... " ".
5aa0: 09 09 09 09 09 20 20 20 63 6f 6d 6d 65 6e 74 29 ..... comment)
5ab0: 20 22 3c 2f 74 64 3e 22 0a 09 09 09 09 09 20 20 "</td>"......
5ac0: 20 22 3c 2f 74 72 3e 22 29 29 29 29 0a 09 20 28 "</tr>")))).. (
5ad0: 69 66 20 28 6c 69 73 74 3f 20 74 65 73 74 64 61 if (list? testda
5ae0: 74 29 0a 09 20 20 20 20 20 74 65 73 74 64 61 74 t).. testdat
5af0: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
5b00: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 (print "ER
5b10: 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 67 ROR: failed to g
5b20: 65 74 20 72 65 63 6f 72 64 73 20 77 69 74 68 20 et records with
5b30: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 rmt:test-get-rec
5b40: 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 ords-for-index-f
5b50: 69 6c 65 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ile run-id=" run
5b60: 2d 69 64 20 22 74 65 73 74 2d 6e 61 6d 65 3d 22 -id "test-name="
5b70: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 20 test-name)..
5b80: 20 20 20 20 27 28 29 29 29 29 0a 09 0a 09 28 70 '())))....(p
5b90: 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 3c 74 72 rint "<table><tr
5ba0: 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 6f ><td valign=\"to
5bb0: 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e 74 p\">")..;; Print
5bc0: 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 73 out stats for s
5bd0: 74 61 74 75 73 0a 09 28 73 65 74 21 20 74 6f 74 tatus..(set! tot
5be0: 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 0)..(print "<ta
5bf0: 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d ble cellspacing=
5c00: 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 \"0\" border=\"1
5c10: 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 \"><tr><td colsp
5c20: 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 an=\"2\"><h2>Sta
5c30: 74 65 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 te stats</h2></t
5c40: 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 2d d></tr>")..(for-
5c50: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 74 each (lambda (st
5c60: 61 74 65 29 0a 09 09 20 20 20 20 28 73 65 74 21 ate)... (set!
5c70: 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 61 73 tot (+ tot (has
5c80: 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 74 61 74 h-table-ref stat
5c90: 65 63 6f 75 6e 74 73 20 73 74 61 74 65 29 29 29 ecounts state)))
5ca0: 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 3c ... (print "<
5cb0: 74 72 3e 3c 74 64 3e 22 20 73 74 61 74 65 20 22 tr><td>" state "
5cc0: 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 </td><td>" (hash
5cd0: 2d 74 61 62 6c 65 2d 72 65 66 20 73 74 61 74 65 -table-ref state
5ce0: 63 6f 75 6e 74 73 20 73 74 61 74 65 29 20 22 3c counts state) "<
5cf0: 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 /td></tr>"))...
5d00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
5d10: 73 20 73 74 61 74 65 63 6f 75 6e 74 73 29 29 0a s statecounts)).
5d20: 09 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 .(print "<tr><td
5d30: 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 >Total</td><td>"
5d40: 20 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e tot "</td></tr>
5d50: 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 </table>")..(pri
5d60: 6e 74 20 22 3c 2f 74 64 3e 3c 74 64 20 76 61 6c nt "</td><td val
5d70: 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 ign=\"top\">")..
5d80: 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 ;; Print out sta
5d90: 74 73 20 66 6f 72 20 73 74 61 74 65 0a 09 28 73 ts for state..(s
5da0: 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 72 69 et! tot 0)..(pri
5db0: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
5dc0: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
5dd0: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
5de0: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
5df0: 3c 68 32 3e 53 74 61 74 75 73 20 73 74 61 74 73 <h2>Status stats
5e00: 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 </h2></td></tr>"
5e10: 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 )..(for-each (la
5e20: 6d 62 64 61 20 28 73 74 61 74 75 73 29 0a 09 09 mbda (status)...
5e30: 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b (set! tot (+
5e40: 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 tot (hash-table
5e50: 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 -ref counts stat
5e60: 75 73 29 29 29 0a 09 09 20 20 20 20 28 70 72 69 us)))... (pri
5e70: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 3c 66 6f 6e nt "<tr><td><fon
5e80: 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 63 6f 6d t color=\"" (com
5e90: 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 mon:get-color-fr
5ea0: 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 om-status status
5eb0: 29 20 22 5c 22 3e 22 20 73 74 61 74 75 73 0a 09 ) "\">" status..
5ec0: 09 09 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 .. "</font></t
5ed0: 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 d><td>" (hash-ta
5ee0: 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 ble-ref counts s
5ef0: 74 61 74 75 73 29 20 22 3c 2f 74 64 3e 3c 2f 74 tatus) "</td></t
5f00: 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 68 2d r>"))... (hash-
5f10: 74 61 62 6c 65 2d 6b 65 79 73 20 63 6f 75 6e 74 table-keys count
5f20: 73 29 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 72 s))..(print "<tr
5f30: 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c ><td>Total</td><
5f40: 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 64 3e 3c td>" tot "</td><
5f50: 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 /tr></table>")..
5f60: 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e 3c 2f 74 (print "</td></t
5f70: 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 d></tr></table>"
5f80: 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 )....(print "<ta
5f90: 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d ble cellspacing=
5fa0: 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 \"0\" border=\"1
5fb0: 5c 22 3e 22 20 0a 09 20 20 20 20 20 20 20 22 3c \">" .. "<
5fc0: 74 72 3e 3c 74 64 3e 49 74 65 6d 3c 2f 74 64 3e tr><td>Item</td>
5fd0: 3c 74 64 3e 53 74 61 74 65 3c 2f 74 64 3e 3c 74 <td>State</td><t
5fe0: 64 3e 53 74 61 74 75 73 3c 2f 74 64 3e 3c 74 64 d>Status</td><td
5ff0: 3e 43 6f 6d 6d 65 6e 74 3c 2f 74 64 3e 22 0a 09 >Comment</td>"..
6000: 20 20 20 20 20 20 20 6f 75 74 74 78 74 20 22 3c outtxt "<
6010: 2f 74 61 62 6c 65 3e 3c 2f 62 6f 64 79 3e 3c 2f /table></body></
6020: 68 74 6d 6c 3e 22 29 0a 09 3b 3b 20 28 72 65 6c html>")..;; (rel
6030: 65 61 73 65 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 ease-dot-lock ou
6040: 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 3b tputfilename)..;
6050: 3b 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e ;(rmt:update-run
6060: 2d 73 74 61 74 73 20 0a 09 3b 3b 20 72 75 6e 2d -stats ..;; run-
6070: 69 64 0a 09 3b 3b 20 28 68 61 73 68 2d 74 61 62 id..;; (hash-tab
6080: 6c 65 2d 6d 61 70 0a 09 3b 3b 20 20 73 74 61 74 le-map..;; stat
6090: 65 2d 73 74 61 74 75 73 2d 63 6f 75 6e 74 73 0a e-status-counts.
60a0: 09 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 .;; (lambda (ke
60b0: 79 20 76 61 6c 29 0a 09 3b 3b 09 28 61 70 70 65 y val)..;;.(appe
60c0: 6e 64 20 6b 65 79 20 28 6c 69 73 74 20 76 61 6c nd key (list val
60d0: 29 29 29 29 29 0a 09 29 29 29 29 0a 0a 28 64 65 )))))..))))..(de
60e0: 66 69 6e 65 20 74 65 73 74 73 3a 63 73 73 2d 6a fine tests:css-j
60f0: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 23 3c 3c script-block.#<<
6100: 45 4f 46 0a 3c 73 74 79 6c 65 20 74 79 70 65 3d EOF.<style type=
6110: 22 74 65 78 74 2f 63 73 73 22 3e 0a 75 6c 2e 4c "text/css">.ul.L
6120: 69 6e 6b 65 64 4c 69 73 74 20 7b 20 64 69 73 70 inkedList { disp
6130: 6c 61 79 3a 20 62 6c 6f 63 6b 3b 20 7d 0a 2f 2a lay: block; }./*
6140: 20 75 6c 2e 4c 69 6e 6b 65 64 4c 69 73 74 20 75 ul.LinkedList u
6150: 6c 20 7b 20 64 69 73 70 6c 61 79 3a 20 6e 6f 6e l { display: non
6160: 65 3b 20 7d 20 2a 2f 0a 2e 48 61 6e 64 43 75 72 e; } */..HandCur
6170: 73 6f 72 53 74 79 6c 65 20 7b 20 63 75 72 73 6f sorStyle { curso
6180: 72 3a 20 70 6f 69 6e 74 65 72 3b 20 63 75 72 73 r: pointer; curs
6190: 6f 72 3a 20 68 61 6e 64 3b 20 7d 20 20 2f 2a 20 or: hand; } /*
61a0: 46 6f 72 20 49 45 20 2a 2f 0a 20 20 3c 2f 73 74 For IE */. </st
61b0: 79 6c 65 3e 0a 0a 20 20 3c 73 63 72 69 70 74 20 yle>.. <script
61c0: 74 79 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 53 type="text/JavaS
61d0: 63 72 69 70 74 22 3e 0a 20 20 20 20 2f 2f 20 41 cript">. // A
61e0: 64 64 20 74 68 69 73 20 74 6f 20 74 68 65 20 6f dd this to the o
61f0: 6e 6c 6f 61 64 20 65 76 65 6e 74 20 6f 66 20 74 nload event of t
6200: 68 65 20 42 4f 44 59 20 65 6c 65 6d 65 6e 74 0a he BODY element.
6210: 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 function add
6220: 45 76 65 6e 74 73 28 29 20 7b 0a 20 20 20 20 20 Events() {.
6230: 20 61 63 74 69 76 61 74 65 54 72 65 65 28 64 6f activateTree(do
6240: 63 75 6d 65 6e 74 2e 67 65 74 45 6c 65 6d 65 6e cument.getElemen
6250: 74 42 79 49 64 28 22 4c 69 6e 6b 65 64 4c 69 73 tById("LinkedLis
6260: 74 31 22 29 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 t1"));. }..
6270: 20 20 2f 2f 20 54 68 69 73 20 66 75 6e 63 74 69 // This functi
6280: 6f 6e 20 74 72 61 76 65 72 73 65 73 20 74 68 65 on traverses the
6290: 20 6c 69 73 74 20 61 6e 64 20 61 64 64 20 6c 69 list and add li
62a0: 6e 6b 73 20 0a 20 20 20 20 2f 2f 20 74 6f 20 6e nks . // to n
62b0: 65 73 74 65 64 20 6c 69 73 74 20 69 74 65 6d 73 ested list items
62c0: 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 63 . function ac
62d0: 74 69 76 61 74 65 54 72 65 65 28 6f 4c 69 73 74 tivateTree(oList
62e0: 29 20 7b 0a 20 20 20 20 20 20 2f 2f 20 43 6f 6c ) {. // Col
62f0: 6c 61 70 73 65 20 74 68 65 20 74 72 65 65 0a 20 lapse the tree.
6300: 20 20 20 20 20 66 6f 72 20 28 76 61 72 20 69 3d for (var i=
6310: 30 3b 20 69 20 3c 20 6f 4c 69 73 74 2e 67 65 74 0; i < oList.get
6320: 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d ElementsByTagNam
6330: 65 28 22 75 6c 22 29 2e 6c 65 6e 67 74 68 3b 20 e("ul").length;
6340: 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 6f i++) {. o
6350: 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 List.getElements
6360: 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 5b ByTagName("ul")[
6370: 69 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 i].style.display
6380: 3d 22 6e 6f 6e 65 22 3b 20 20 20 20 20 20 20 20 ="none";
6390: 20 20 20 20 0a 20 20 20 20 20 20 7d 20 20 20 20 . }
63a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
63e0: 20 20 20 20 20 2f 2f 20 41 64 64 20 74 68 65 20 // Add the
63f0: 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e 64 click-event hand
6400: 6c 65 72 20 74 6f 20 74 68 65 20 6c 69 73 74 20 ler to the list
6410: 69 74 65 6d 73 0a 20 20 20 20 20 20 69 66 20 28 items. if (
6420: 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e 74 4c 69 oList.addEventLi
6430: 73 74 65 6e 65 72 29 20 7b 0a 20 20 20 20 20 20 stener) {.
6440: 20 20 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e 74 oList.addEvent
6450: 4c 69 73 74 65 6e 65 72 28 22 63 6c 69 63 6b 22 Listener("click"
6460: 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 2c 20 , toggleBranch,
6470: 66 61 6c 73 65 29 3b 0a 20 20 20 20 20 20 7d 20 false);. }
6480: 65 6c 73 65 20 69 66 20 28 6f 4c 69 73 74 2e 61 else if (oList.a
6490: 74 74 61 63 68 45 76 65 6e 74 29 20 7b 20 2f 2f ttachEvent) { //
64a0: 20 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 For IE.
64b0: 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 6e oList.attachEven
64c0: 74 28 22 6f 6e 63 6c 69 63 6b 22 2c 20 74 6f 67 t("onclick", tog
64d0: 67 6c 65 42 72 61 6e 63 68 29 3b 0a 20 20 20 20 gleBranch);.
64e0: 20 20 7d 0a 20 20 20 20 20 20 2f 2f 20 4d 61 6b }. // Mak
64f0: 65 20 74 68 65 20 6e 65 73 74 65 64 20 69 74 65 e the nested ite
6500: 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 6e ms look like lin
6510: 6b 73 0a 20 20 20 20 20 20 61 64 64 4c 69 6e 6b ks. addLink
6520: 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c 69 73 sToBranches(oLis
6530: 74 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f t);. }.. /
6540: 2f 20 54 68 69 73 20 69 73 20 74 68 65 20 63 6c / This is the cl
6550: 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e 64 6c 65 ick-event handle
6560: 72 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 74 r. function t
6570: 6f 67 67 6c 65 42 72 61 6e 63 68 28 65 76 65 6e oggleBranch(even
6580: 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 6f t) {. var o
6590: 42 72 61 6e 63 68 2c 20 63 53 75 62 42 72 61 6e Branch, cSubBran
65a0: 63 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 28 ches;. if (
65b0: 65 76 65 6e 74 2e 74 61 72 67 65 74 29 20 7b 0a event.target) {.
65c0: 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 20 oBranch
65d0: 3d 20 65 76 65 6e 74 2e 74 61 72 67 65 74 3b 0a = event.target;.
65e0: 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 20 } else if
65f0: 28 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 6e (event.srcElemen
6600: 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a 20 t) { // For IE.
6610: 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 20 3d oBranch =
6620: 20 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 6e event.srcElemen
6630: 74 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 20 t;. }.
6640: 20 63 53 75 62 42 72 61 6e 63 68 65 73 20 3d 20 cSubBranches =
6650: 6f 42 72 61 6e 63 68 2e 67 65 74 45 6c 65 6d 65 oBranch.getEleme
6660: 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c ntsByTagName("ul
6670: 22 29 3b 0a 20 20 20 20 20 20 69 66 20 28 63 53 ");. if (cS
6680: 75 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 ubBranches.lengt
6690: 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 h > 0) {.
66a0: 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 if (cSubBranche
66b0: 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c s[0].style.displ
66c0: 61 79 20 3d 3d 20 22 62 6c 6f 63 6b 22 29 20 7b ay == "block") {
66d0: 0a 20 20 20 20 20 20 20 20 20 20 63 53 75 62 42 . cSubB
66e0: 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 ranches[0].style
66f0: 2e 64 69 73 70 6c 61 79 20 3d 20 22 6e 6f 6e 65 .display = "none
6700: 22 3b 0a 20 20 20 20 20 20 20 20 7d 20 65 6c 73 ";. } els
6710: 65 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 e {. cS
6720: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
6730: 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 62 yle.display = "b
6740: 6c 6f 63 6b 22 3b 0a 20 20 20 20 20 20 20 20 7d lock";. }
6750: 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 7d 0a 0a . }. }..
6760: 20 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e 63 // This func
6770: 74 69 6f 6e 20 6d 61 6b 65 73 20 6e 65 73 74 65 tion makes neste
6780: 64 20 6c 69 73 74 20 69 74 65 6d 73 20 6c 6f 6f d list items loo
6790: 6b 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 k like links.
67a0: 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 4c 69 6e function addLin
67b0: 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c 69 ksToBranches(oLi
67c0: 73 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 st) {. var
67d0: 63 42 72 61 6e 63 68 65 73 20 3d 20 6f 4c 69 73 cBranches = oLis
67e0: 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 t.getElementsByT
67f0: 61 67 4e 61 6d 65 28 22 6c 69 22 29 3b 0a 20 20 agName("li");.
6800: 20 20 20 20 76 61 72 20 69 2c 20 6e 2c 20 63 53 var i, n, cS
6810: 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 20 20 ubBranches;.
6820: 20 20 69 66 20 28 63 42 72 61 6e 63 68 65 73 2e if (cBranches.
6830: 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 20 length > 0) {.
6840: 20 20 20 20 20 20 66 6f 72 20 28 69 3d 30 2c 20 for (i=0,
6850: 6e 20 3d 20 63 42 72 61 6e 63 68 65 73 2e 6c 65 n = cBranches.le
6860: 6e 67 74 68 3b 20 69 20 3c 20 6e 3b 20 69 2b 2b ngth; i < n; i++
6870: 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 ) {. cS
6880: 75 62 42 72 61 6e 63 68 65 73 20 3d 20 63 42 72 ubBranches = cBr
6890: 61 6e 63 68 65 73 5b 69 5d 2e 67 65 74 45 6c 65 anches[i].getEle
68a0: 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 mentsByTagName("
68b0: 75 6c 22 29 3b 0a 20 20 20 20 20 20 20 20 20 20 ul");.
68c0: 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 73 if (cSubBranches
68d0: 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 .length > 0) {.
68e0: 20 20 20 20 20 20 20 20 20 20 20 61 64 64 4c 69 addLi
68f0: 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 63 53 nksToBranches(cS
6900: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 29 3b 0a ubBranches[0]);.
6910: 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 61 cBra
6920: 6e 63 68 65 73 5b 69 5d 2e 63 6c 61 73 73 4e 61 nches[i].classNa
6930: 6d 65 20 3d 20 22 48 61 6e 64 43 75 72 73 6f 72 me = "HandCursor
6940: 53 74 79 6c 65 22 3b 0a 20 20 20 20 20 20 20 20 Style";.
6950: 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 5d cBranches[i]
6960: 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 3d 20 22 .style.color = "
6970: 62 6c 75 65 22 3b 0a 20 20 20 20 20 20 20 20 20 blue";.
6980: 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b cSubBranches[
6990: 30 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 3d 0].style.color =
69a0: 20 22 62 6c 61 63 6b 22 3b 0a 20 20 20 20 20 20 "black";.
69b0: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
69c0: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 75 72 73 es[0].style.curs
69d0: 6f 72 20 3d 20 22 61 75 74 6f 22 3b 0a 20 20 20 or = "auto";.
69e0: 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 20 }.
69f0: 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 7d }. }. }
6a00: 0a 20 20 3c 2f 73 63 72 69 70 74 3e 0a 45 4f 46 . </script>.EOF
6a10: 0a 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .)..(define (tes
6a20: 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 ts:run-record->t
6a30: 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d est-path run num
6a40: 6b 65 79 73 29 0a 20 20 20 28 61 70 70 65 6e 64 keys). (append
6a50: 20 28 74 61 6b 65 20 28 76 65 63 74 6f 72 2d 3e (take (vector->
6a60: 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d 6b 65 79 list run) numkey
6a70: 73 29 0a 09 20 20 20 28 6c 69 73 74 20 28 76 65 s).. (list (ve
6a80: 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 28 2b 20 ctor-ref run (+
6a90: 31 20 6e 75 6d 6b 65 79 73 29 29 29 29 29 0a 0a 1 numkeys)))))..
6aa0: 3b 3b 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 ;; (tests:create
6ab0: 2d 68 74 6d 6c 2d 74 72 65 65 20 22 74 65 73 74 -html-tree "test
6ac0: 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 0a 3b 3b -index.html").;;
6ad0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
6ae0: 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 create-html-tree
6af0: 20 6f 75 74 66 29 0a 20 20 28 6c 65 74 2a 20 28 outf). (let* (
6b00: 28 6c 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 (lockfile (conc
6b10: 20 6f 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a outf ".lock")).
6b20: 09 20 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 . (runs-to-proce
6b30: 73 73 20 27 28 29 29 29 0a 20 20 20 20 28 69 66 ss '())). (if
6b40: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
6b50: 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 file-lock lockfi
6b60: 6c 65 29 0a 09 28 6c 65 74 2a 20 28 28 6c 69 6e le)..(let* ((lin
6b70: 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 ktree (common:g
6b80: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 20 et-linktree))..
6b90: 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 (oup
6ba0: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
6bb0: 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e le (or outf (con
6bc0: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 72 75 6e c linktree "/run
6bd0: 73 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 29 29 s-index.html")))
6be0: 29 0a 09 20 20 20 20 20 20 20 28 61 72 65 61 2d ).. (area-
6bf0: 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 name (common:get
6c00: 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 -testsuite-name)
6c10: 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 73 20 ).. (keys
6c20: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 (rmt:get-ke
6c30: 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 ys)).. (nu
6c40: 6d 6b 65 79 73 20 20 20 28 6c 65 6e 67 74 68 20 mkeys (length
6c50: 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 keys)).. (
6c60: 72 75 6e 73 64 61 74 20 20 20 28 72 6d 74 3a 67 runsdat (rmt:g
6c70: 65 74 2d 72 75 6e 73 20 22 25 22 20 23 66 20 23 et-runs "%" #f #
6c80: 66 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 f (map (lambda (
6c90: 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 x)(list x "%"))
6ca0: 6b 65 79 73 29 29 29 0a 09 20 20 20 20 20 20 20 keys)))..
6cb0: 28 68 65 61 64 65 72 20 20 20 20 28 76 65 63 74 (header (vect
6cc0: 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 30 or-ref runsdat 0
6cd0: 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 )).. (runs
6ce0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
6cf0: 66 20 72 75 6e 73 64 61 74 20 31 29 29 0a 09 20 f runsdat 1))..
6d00: 20 20 20 20 20 20 28 72 75 6e 74 72 65 65 64 61 (runtreeda
6d10: 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 t (map (lambda (
6d20: 78 29 0a 09 09 09 09 20 20 28 74 65 73 74 73 3a x)..... (tests:
6d30: 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 run-record->test
6d40: 2d 70 61 74 68 20 78 20 6e 75 6d 6b 65 79 73 29 -path x numkeys)
6d50: 29 0a 09 09 09 09 72 75 6e 73 29 29 0a 09 20 20 ).....runs))..
6d60: 20 20 20 20 20 28 72 75 6e 73 2d 68 74 72 65 65 (runs-htree
6d70: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 (common:list->h
6d80: 74 72 65 65 20 72 75 6e 74 72 65 65 64 61 74 29 tree runtreedat)
6d90: 29 29 0a 09 20 20 28 73 65 74 21 20 72 75 6e 73 )).. (set! runs
6da0: 2d 74 6f 2d 70 72 6f 63 65 73 73 20 72 75 6e 73 -to-process runs
6db0: 29 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e ).. (s:output-n
6dc0: 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 ew.. oup.. (
6dd0: 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 s:html tests:css
6de0: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 09 -jscript-block..
6df0: 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 . (s:title "Su
6e00: 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 mmary for " area
6e10: 2d 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 -name)... (s:b
6e20: 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 64 ody 'onload "add
6e30: 45 76 65 6e 74 73 28 29 3b 22 0a 09 09 09 20 20 Events();"....
6e40: 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 20 (s:h1 "Summary
6e50: 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 for " area-name)
6e60: 0a 09 09 09 20 20 20 3b 3b 20 74 6f 70 20 6c 69 .... ;; top li
6e70: 73 74 0a 09 09 09 20 20 20 28 73 3a 75 6c 20 27 st.... (s:ul '
6e80: 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 id "LinkedList1"
6e90: 20 27 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 4c 'class "LinkedL
6ea0: 69 73 74 22 0a 09 09 09 09 20 28 73 3a 6c 69 0a ist"..... (s:li.
6eb0: 09 09 09 09 20 20 22 52 75 6e 73 22 0a 09 09 09 .... "Runs"....
6ec0: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 . (common:htree
6ed0: 2d 3e 68 74 6d 6c 20 72 75 6e 73 2d 68 74 72 65 ->html runs-htre
6ee0: 65 0a 09 09 09 09 09 09 20 20 20 20 20 20 27 28 e....... '(
6ef0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6c )....... (l
6f00: 61 6d 62 64 61 20 28 78 20 70 29 0a 09 09 09 09 ambda (x p).....
6f10: 09 09 09 28 6c 65 74 2a 20 28 28 74 61 72 67 2d ...(let* ((targ-
6f20: 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 path (string-int
6f30: 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 ersperse p "/"))
6f40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f80: 28 66 75 6c 6c 2d 70 61 74 68 20 28 63 6f 6e 63 (full-path (conc
6f90: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 linktree "/" ta
6fa0: 72 67 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 rg-path)).
6fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fe0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 (run-na
6ff0: 6d 65 20 20 28 63 61 72 20 28 72 65 76 65 72 73 me (car (revers
7000: 65 20 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 e p)))).
7010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7040: 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 (if (and (file
7050: 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 70 61 -exists? full-pa
7060: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
7070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70a0: 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 (director
70b0: 79 3f 20 20 20 66 75 6c 6c 2d 70 61 74 68 29 0a y? full-path).
70c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7100: 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 (file-write-a
7110: 63 63 65 73 73 3f 20 66 75 6c 6c 2d 70 61 74 68 ccess? full-path
7120: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7160: 20 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 27 (s:a run-name '
7170: 68 72 65 66 20 28 63 6f 6e 63 20 74 61 72 67 2d href (conc targ-
7180: 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 path "/run-summa
7190: 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 ry.html")).
71a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71d0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
71e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7220: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
7230: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7240: 2a 20 22 49 4e 46 4f 3a 20 43 61 6e 27 74 20 63 * "INFO: Can't c
7250: 72 65 61 74 65 20 22 20 74 61 72 67 2d 70 61 74 reate " targ-pat
7260: 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e h "/run-summary.
7270: 68 74 6d 6c 22 29 0a 20 20 20 20 20 20 20 20 20 html").
7280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72b0: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 75 6e (conc run
72c0: 2d 6e 61 6d 65 20 22 20 28 4e 6f 74 20 61 62 6c -name " (Not abl
72d0: 65 20 74 6f 20 63 72 65 61 74 65 20 73 75 6d 6d e to create summ
72e0: 61 72 79 20 61 74 20 22 20 74 61 72 67 2d 70 61 ary at " targ-pa
72f0: 74 68 20 22 29 22 29 29 29 29 29 29 29 29 29 29 th ")"))))))))))
7300: 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f ). (clo
7310: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
7320: 75 70 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 up).. (common:s
7330: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
7340: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 se-lock lockfile
7350: 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 ).. (for-each..
7360: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 (lambda (run)
7370: 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 .. (let* ((t
7380: 65 73 74 2d 73 75 62 70 61 74 68 20 28 74 65 73 est-subpath (tes
7390: 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 ts:run-record->t
73a0: 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d est-path run num
73b0: 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 72 75 keys))... (ru
73c0: 6e 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a 67 n-id (db:g
73d0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
73e0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
73f0: 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d")).
7400: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 (run-di
7410: 72 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 r (tests:ru
7420: 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 n-record->test-p
7430: 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 ath run numkeys)
7440: 29 0a 09 09 20 20 20 20 28 74 65 73 74 2d 64 61 )... (test-da
7450: 74 73 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 ts (rmt:get-t
7460: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 ests-for-run....
7470: 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 . run-id.
7480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
74a0: 2f 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 /" ;; test
74b0: 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 namepatt.....
74c0: 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 '() ;; st
74d0: 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 ates..... '()
74e0: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 ;; status
74f0: 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 es..... #f
7500: 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 ;; offset..
7510: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7520: 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 ;; num-to-get..
7530: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7540: 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 ;; hide/not-hid
7550: 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 e..... #f
7560: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 ;; sort-by..
7570: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7580: 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 ;; sort-order..
7590: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
75a0: 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 ;; 'shortlist
75b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
75c0: 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 ;; qryt
75d0: 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ype.
75e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
75f0: 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 0
7600: 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a ;; last update.
7610: 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 .... #f)).
7620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7630: 28 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 20 (tests-tree-dat
7640: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
7650: 73 74 2d 64 61 74 29 0a 20 20 20 20 20 20 20 20 st-dat).
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7680: 20 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 ;; (tests:run-r
7690: 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 ecord->test-path
76a0: 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 x numkeys)).
76b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76d0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
76e0: 73 74 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 st-name (db:tes
76f0: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
7700: 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 est-dat)).
7710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7730: 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d (item-
7740: 70 61 74 68 20 20 28 64 62 3a 74 65 73 74 2d 67 path (db:test-g
7750: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
7760: 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 t-dat)).
7770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7790: 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 (full-na
77a0: 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b me (db:test-mak
77b0: 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 e-full-name test
77c0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
77d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
77e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7800: 20 20 28 70 61 74 68 2d 70 61 72 74 73 20 28 73 (path-parts (s
7810: 74 72 69 6e 67 2d 73 70 6c 69 74 20 66 75 6c 6c tring-split full
7820: 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 -name))).
7830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7850: 20 20 20 20 70 61 74 68 2d 70 61 72 74 73 29 29 path-parts))
7860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7880: 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 test-dat
7890: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
78a0: 20 20 20 20 20 20 20 20 28 74 65 73 74 73 2d 68 (tests-h
78b0: 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 tree (common:lis
78c0: 74 2d 3e 68 74 72 65 65 20 74 65 73 74 73 2d 74 t->htree tests-t
78d0: 72 65 65 2d 64 61 74 29 29 0a 20 20 20 20 20 20 ree-dat)).
78e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
78f0: 74 6d 6c 2d 64 69 72 20 20 20 20 28 63 6f 6e 63 tml-dir (conc
7900: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 28 73 linktree "/" (s
7910: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7920: 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 29 e run-dir "/")))
7930: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7940: 20 20 20 20 20 28 68 74 6d 6c 2d 70 61 74 68 20 (html-path
7950: 20 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 (conc html-dir
7960: 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 "/run-summary.h
7970: 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 tml")).
7980: 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 70 20 (oup
7990: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
79a0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 (file-exists? h
79b0: 74 6d 6c 2d 64 69 72 29 0a 20 20 20 20 20 20 20 tml-dir).
79c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79e0: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 20 (directory?
79f0: 20 68 74 6d 6c 2d 64 69 72 29 0a 20 20 20 20 20 html-dir).
7a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a20: 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 (file-write
7a30: 2d 61 63 63 65 73 73 3f 20 68 74 6d 6c 2d 64 69 -access? html-di
7a40: 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 r)).
7a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a60: 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f (open-o
7a70: 75 74 70 75 74 2d 66 69 6c 65 20 20 68 74 6d 6c utput-file html
7a80: 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 -path).
7a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
7ab0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7ac0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 6e 2d ;; (print "run-
7ad0: 64 69 72 3a 20 22 20 72 75 6e 2d 64 69 72 20 22 dir: " run-dir "
7ae0: 2c 20 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 , tests-tree-dat
7af0: 3a 20 22 20 74 65 73 74 73 2d 74 72 65 65 2d 64 : " tests-tree-d
7b00: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
7b10: 20 20 20 28 69 66 20 6f 75 70 0a 20 20 20 20 20 (if oup.
7b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
7b30: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
7b40: 20 20 20 20 20 20 20 20 20 20 28 73 3a 6f 75 74 (s:out
7b50: 70 75 74 2d 6e 65 77 0a 20 20 20 20 20 20 20 20 put-new.
7b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 75 ou
7b70: 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 p.
7b80: 20 20 20 20 20 20 20 20 28 73 3a 68 74 6d 6c 20 (s:html
7b90: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
7ba0: 74 2d 62 6c 6f 63 6b 0a 20 20 20 20 20 20 20 20 t-block.
7bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bc0: 20 20 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 (s:title "
7bd0: 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 Summary for " ar
7be0: 65 61 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 ea-name).
7bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c00: 20 20 20 20 20 20 20 28 73 3a 62 6f 64 79 20 27 (s:body '
7c10: 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 onload "addEvent
7c20: 73 28 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 s();".
7c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c40: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 68 (s:h
7c50: 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 1 "Summary for "
7c60: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7c70: 65 72 73 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 erse run-dir "/"
7c80: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ca0: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 6f 70 20 ;; top
7cb0: 6c 69 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 list.
7cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cd0: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 75 6c (s:ul
7ce0: 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 'id "LinkedList
7cf0: 31 22 20 27 63 6c 61 73 73 20 22 4c 69 6e 6b 65 1" 'class "Linke
7d00: 64 4c 69 73 74 22 0a 20 20 20 20 20 20 20 20 20 dList".
7d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d30: 20 20 20 28 73 3a 6c 69 0a 20 20 20 20 20 20 20 (s:li.
7d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d60: 20 20 20 20 20 20 22 54 65 73 74 73 22 0a 20 20 "Tests".
7d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d90: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d (comm
7da0: 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 74 on:htree->html t
7db0: 65 73 74 73 2d 68 74 72 65 65 0a 20 20 20 20 20 ests-htree.
7dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7df0: 20 20 20 20 20 20 20 20 20 20 20 20 27 28 29 0a '().
7e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e40: 20 28 6c 61 6d 62 64 61 20 28 78 20 70 29 0a 20 (lambda (x p).
7e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e90: 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 (let* ((targ-p
7ea0: 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 ath (string-inte
7eb0: 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a rsperse p "/")).
7ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f00: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
7f10: 6e 61 6d 65 20 28 63 61 72 20 70 29 29 0a 20 20 name (car p)).
7f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 (item-pa
7f70: 74 68 20 3b 3b 20 28 69 66 20 28 3e 20 28 6c 65 th ;; (if (> (le
7f80: 6e 67 74 68 20 70 29 20 32 29 20 3b 3b 20 74 65 ngth p) 2) ;; te
7f90: 73 74 2d 6e 61 6d 65 20 2b 20 72 75 6e 2d 6e 61 st-name + run-na
7fa0: 6d 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 me.
7fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
7ff0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
8000: 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 e p "/")).
8010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8050: 20 20 20 20 28 66 75 6c 6c 2d 74 61 72 67 20 28 (full-targ (
8060: 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 20 22 2f conc html-dir "/
8070: 22 20 74 61 72 67 2d 70 61 74 68 29 29 0a 20 20 " targ-path)).
8080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80c0: 20 20 20 20 20 20 20 20 28 73 74 64 2d 66 69 6c (std-fil
80d0: 65 20 20 28 63 6f 6e 63 20 66 75 6c 6c 2d 74 61 e (conc full-ta
80e0: 72 67 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 rg "/test-summar
80f0: 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 y.html")).
8100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8140: 20 20 20 20 28 61 6c 74 2d 66 69 6c 65 20 20 28 (alt-file (
8150: 63 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 67 20 22 conc full-targ "
8160: 2f 6d 65 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 /megatest-rollup
8170: 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 -" test-name ".h
8180: 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 tml")).
8190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81d0: 20 28 68 74 6d 6c 2d 66 69 6c 65 20 28 69 66 20 (html-file (if
81e0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c (file-exists? al
81f0: 74 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 t-file).
8200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8250: 20 61 6c 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 alt-file.
8260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82b0: 20 20 20 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 std-file)).
82c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8300: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d (run-nam
8310: 65 20 20 28 63 61 72 20 28 72 65 76 65 72 73 65 e (car (reverse
8320: 20 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 p)))).
8330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8360: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
8370: 28 61 6e 64 20 28 6e 6f 74 20 28 66 69 6c 65 2d (and (not (file-
8380: 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 exists? full-tar
8390: 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 g)).
83a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83e0: 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 66 75 (directory? fu
83f0: 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 ll-targ).
8400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8440: 20 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 (file-wri
8450: 74 65 2d 61 63 63 65 73 73 3f 20 66 75 6c 6c 2d te-access? full-
8460: 74 61 72 67 29 29 0a 20 20 20 20 20 20 20 20 20 targ)).
8470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84b0: 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 (tests:summarize
84c0: 2d 74 65 73 74 20 0a 20 20 20 20 20 20 20 20 20 -test .
84d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8510: 20 72 75 6e 2d 69 64 20 0a 20 20 20 20 20 20 20 run-id .
8520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8560: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
8570: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
8580: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
8590: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
85a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85d0: 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 (if (file
85e0: 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 -exists? full-ta
85f0: 72 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 rg).
8600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8630: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
8640: 61 20 72 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 a run-name 'href
8650: 20 68 74 6d 6c 2d 66 69 6c 65 29 0a 20 20 20 20 html-file).
8660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86a0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
86b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86f0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
8700: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
8710: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
8720: 20 63 61 6e 27 74 20 61 63 63 65 73 73 20 22 20 can't access "
8730: 66 75 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 full-targ).
8740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 4e 6f 20 (conc "No
8790: 73 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 72 75 summary for " ru
87a0: 6e 2d 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 n-name))))).
87b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 29 )))
87f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
8800: 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d (close-
8810: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
8820: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
8830: 72 75 6e 73 29 0a 20 20 20 20 20 20 20 20 20 20 runs).
8840: 23 74 29 0a 09 23 66 29 29 29 0a 0a 0a 3b 3b 20 #t)..#f)))...;;
8850: 43 48 45 43 4b 20 2d 20 57 41 53 20 54 48 49 53 CHECK - WAS THIS
8860: 20 41 44 44 45 44 20 4f 52 20 52 45 4d 4f 56 45 ADDED OR REMOVE
8870: 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 47 45 20 D? MANUAL MERGE
8880: 57 49 54 48 20 41 50 49 20 53 54 55 46 46 21 21 WITH API STUFF!!
8890: 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 70 72 !.;;.;; get a pr
88a0: 65 74 74 79 20 74 61 62 6c 65 20 74 6f 20 73 75 etty table to su
88b0: 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 0a 3b 3b mmarize steps.;;
88c0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 63 6f .;; (define (dco
88d0: 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 74 65 mmon:process-ste
88e0: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b ps-table steps);
88f0: 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b ; db test-id #!k
8900: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
8910: 29 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )).(define (test
8920: 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d s:process-steps-
8930: 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 table steps);; d
8940: 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 b test-id #!key
8950: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a (work-area #f)).
8960: 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 65 70 73 ;; (let ((steps
8970: 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 70 73 (db:get-steps
8980: 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 74 65 73 -for-test db tes
8990: 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 t-id work-area:
89a0: 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 work-area))).
89b0: 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 74 68 65 ;; organise the
89c0: 20 73 74 65 70 73 20 66 6f 72 20 62 65 74 74 65 steps for bette
89d0: 72 20 72 65 61 64 61 62 69 6c 69 74 79 0a 20 20 r readability.
89e0: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6d 61 (let ((res (ma
89f0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
8a00: 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
8a10: 20 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 . (lambda
8a20: 20 28 73 74 65 70 29 0a 09 20 28 64 65 62 75 67 (step).. (debug
8a30: 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c :print 6 *defaul
8a40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 65 t-log-port* "ste
8a50: 70 3d 22 20 73 74 65 70 29 0a 09 20 28 6c 65 74 p=" step).. (let
8a60: 20 28 28 72 65 63 6f 72 64 20 28 68 61 73 68 2d ((record (hash-
8a70: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
8a80: 74 20 0a 09 09 09 72 65 73 20 0a 09 09 09 28 74 t ....res ....(t
8a90: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 db:step-get-step
8aa0: 6e 61 6d 65 20 73 74 65 70 29 20 0a 09 09 09 3b name step) ....;
8ab0: 3b 20 20 20 20 20 20 20 20 73 74 65 70 6e 61 6d ; stepnam
8ac0: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
8ad0: 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 75 start end statu
8ae0: 73 20 44 75 72 61 74 69 6f 6e 20 20 4c 6f 67 66 s Duration Logf
8af0: 69 6c 65 20 43 6f 6d 6d 65 6e 74 0a 09 09 09 28 ile Comment....(
8b00: 76 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 70 vector (tdb:step
8b10: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
8b20: 65 70 29 20 22 22 20 20 20 22 22 20 22 22 20 20 ep) "" "" ""
8b30: 20 20 20 22 22 20 20 20 20 20 20 20 20 22 22 20 "" ""
8b40: 20 20 20 20 22 22 29 29 29 29 0a 09 20 20 20 28 "")))).. (
8b50: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 debug:print 6 *d
8b60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
8b70: 20 22 72 65 63 6f 72 64 28 62 65 66 6f 72 65 29 "record(before)
8b80: 20 3d 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 = " record ....
8b90: 22 5c 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 "\nid: " (
8ba0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 tdb:step-get-id
8bb0: 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 step)...."\nstep
8bc0: 6e 61 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 name: " (tdb:ste
8bd0: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
8be0: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 tep)...."\nstate
8bf0: 3a 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 : " (tdb:step
8c00: 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 -get-state step)
8c10: 0a 09 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 ...."\nstatus:
8c20: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
8c30: 2d 73 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 -status step)...
8c40: 09 22 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 ."\ntime: "
8c50: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
8c60: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a ent_time step)).
8c70: 09 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e . (case (strin
8c80: 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 64 62 3a 73 g->symbol (tdb:s
8c90: 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 tep-get-state st
8ca0: 65 70 29 29 0a 09 20 20 20 20 20 28 28 73 74 61 ep)).. ((sta
8cb0: 72 74 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 rt)(vector-set!
8cc0: 72 65 63 6f 72 64 20 31 20 28 74 64 62 3a 73 74 record 1 (tdb:st
8cd0: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
8ce0: 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 e step))..
8cf0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
8d00: 6f 72 64 20 33 20 28 69 66 20 28 65 71 75 61 6c ord 3 (if (equal
8d10: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 ? (vector-ref re
8d20: 63 6f 72 64 20 33 29 20 22 22 29 0a 09 09 09 09 cord 3) "").....
8d30: 09 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 .(tdb:step-get-s
8d40: 74 61 74 75 73 20 73 74 65 70 29 29 29 0a 09 20 tatus step)))..
8d50: 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 (if (> (str
8d60: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a ing-length (tdb:
8d70: 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 step-get-logfile
8d80: 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 step))... 0
8d90: 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 )... (vector-se
8da0: 74 21 20 72 65 63 6f 72 64 20 35 20 28 74 64 62 t! record 5 (tdb
8db0: 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c :step-get-logfil
8dc0: 65 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 20 e step))))..
8dd0: 20 28 28 65 6e 64 29 20 20 0a 09 20 20 20 20 20 ((end) ..
8de0: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
8df0: 63 6f 72 64 20 32 20 28 61 6e 79 2d 3e 6e 75 6d cord 2 (any->num
8e00: 62 65 72 20 28 74 64 62 3a 73 74 65 70 2d 67 65 ber (tdb:step-ge
8e10: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
8e20: 70 29 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 p))).. (vec
8e30: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
8e40: 33 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 3 (tdb:step-get-
8e50: 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 20 status step))..
8e60: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
8e70: 21 20 72 65 63 6f 72 64 20 34 20 28 6c 65 74 20 ! record 4 (let
8e80: 28 28 73 74 61 72 74 74 20 28 61 6e 79 2d 3e 6e ((startt (any->n
8e90: 75 6d 62 65 72 20 28 76 65 63 74 6f 72 2d 72 65 umber (vector-re
8ea0: 66 20 72 65 63 6f 72 64 20 31 29 29 29 0a 09 09 f record 1)))...
8eb0: 09 09 09 20 20 28 65 6e 64 74 20 20 20 28 61 6e ... (endt (an
8ec0: 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 74 6f y->number (vecto
8ed0: 72 2d 72 65 66 20 72 65 63 6f 72 64 20 32 29 29 r-ref record 2))
8ee0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 ))..... (de
8ef0: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
8f00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8f10: 72 65 63 6f 72 64 5b 31 5d 3d 22 20 28 76 65 63 record[1]=" (vec
8f20: 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 31 tor-ref record 1
8f30: 29 20 0a 09 09 09 09 09 09 20 20 20 22 2c 20 73 ) ....... ", s
8f40: 74 61 72 74 74 3d 22 20 73 74 61 72 74 74 20 22 tartt=" startt "
8f50: 2c 20 65 6e 64 74 3d 22 20 65 6e 64 74 0a 09 09 , endt=" endt...
8f60: 09 09 09 09 20 20 20 22 2c 20 67 65 74 2d 73 74 .... ", get-st
8f70: 61 74 75 73 3a 20 22 20 28 74 64 62 3a 73 74 65 atus: " (tdb:ste
8f80: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
8f90: 70 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 p))..... (i
8fa0: 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 f (and (number?
8fb0: 73 74 61 72 74 74 29 28 6e 75 6d 62 65 72 3f 20 startt)(number?
8fc0: 65 6e 64 74 29 29 0a 09 09 09 09 09 20 20 28 73 endt))...... (s
8fd0: 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 econds->hr-min-s
8fe0: 65 63 20 28 2d 20 65 6e 64 74 20 73 74 61 72 74 ec (- endt start
8ff0: 74 29 29 20 22 2d 31 22 29 29 29 0a 09 20 20 20 t)) "-1")))..
9000: 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e (if (> (strin
9010: 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 74 g-length (tdb:st
9020: 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 ep-get-logfile s
9030: 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 29 0a tep))... 0).
9040: 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 .. (vector-set!
9050: 20 72 65 63 6f 72 64 20 35 20 28 74 64 62 3a 73 record 5 (tdb:s
9060: 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 tep-get-logfile
9070: 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 28 step))).. (
9080: 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 if (> (string-le
9090: 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d 67 ngth (tdb:step-g
90a0: 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 et-comment step)
90b0: 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 20 )... 0)...
90c0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
90d0: 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 70 2d ord 6 (tdb:step-
90e0: 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 get-comment step
90f0: 29 29 29 29 0a 09 20 20 20 20 20 28 65 6c 73 65 )))).. (else
9100: 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d .. (vector-
9110: 73 65 74 21 20 72 65 63 6f 72 64 20 32 20 28 74 set! record 2 (t
9120: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
9130: 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 e step))..
9140: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
9150: 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 70 2d ord 3 (tdb:step-
9160: 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 get-status step)
9170: 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 ).. (vector
9180: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 20 28 -set! record 4 (
9190: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
91a0: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 nt_time step))..
91b0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
91c0: 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 62 t! record 6 (tdb
91d0: 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e :step-get-commen
91e0: 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 28 t step)))).. (
91f0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9200: 72 65 73 20 28 74 64 62 3a 73 74 65 70 2d 67 65 res (tdb:step-ge
9210: 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 t-stepname step)
9220: 20 72 65 63 6f 72 64 29 0a 09 20 20 20 28 64 65 record).. (de
9230: 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 bug:print 6 *def
9240: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
9250: 72 65 63 6f 72 64 28 61 66 74 65 72 29 20 20 3d record(after) =
9260: 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 22 5c " record ...."\
9270: 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 74 64 nid: " (td
9280: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 74 b:step-get-id st
9290: 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 ep)...."\nstepna
92a0: 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 70 2d me: " (tdb:step-
92b0: 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 get-stepname ste
92c0: 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 p)...."\nstate:
92d0: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
92e0: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 0a 09 et-state step)..
92f0: 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 .."\nstatus: "
9300: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
9310: 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 09 22 tatus step)...."
9320: 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 28 74 \ntime: " (t
9330: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
9340: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 29 0a t_time step)))).
9350: 20 20 20 20 20 20 20 3b 3b 20 28 65 6c 73 65 20 ;; (else
9360: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
9370: 65 63 6f 72 64 20 31 20 28 74 64 62 3a 73 74 65 ecord 1 (tdb:ste
9380: 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 p-get-event_time
9390: 20 73 74 65 70 29 29 29 0a 20 20 20 20 20 20 20 step))).
93a0: 28 73 6f 72 74 20 73 74 65 70 73 20 28 6c 61 6d (sort steps (lam
93b0: 62 64 61 20 28 61 20 62 29 0a 09 09 20 20 20 20 bda (a b)...
93c0: 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 20 28 (cond... (
93d0: 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 2d 67 (< (tdb:step-g
93e0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 et-event_time a)
93f0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
9400: 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 23 74 29 ent_time b)) #t)
9410: 0a 09 09 20 20 20 20 20 20 28 28 65 71 3f 20 28 ... ((eq? (
9420: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
9430: 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 3a 73 nt_time a)(tdb:s
9440: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
9450: 6d 65 20 62 29 29 20 0a 09 09 20 20 20 20 20 20 me b)) ...
9460: 20 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 2d (< (tdb:step-
9470: 67 65 74 2d 69 64 20 61 29 20 20 20 20 20 20 20 get-id a)
9480: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 (tdb:step-get-i
9490: 64 20 62 29 29 29 0a 09 09 20 20 20 20 20 20 28 d b)))... (
94a0: 65 6c 73 65 20 23 66 29 29 29 29 29 0a 20 20 20 else #f))))).
94b0: 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 0a 3b 3b res))..;; .;;
94c0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
94d0: 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 get-compressed-s
94e0: 74 65 70 73 20 72 75 6e 2d 69 64 20 74 65 73 74 teps run-id test
94f0: 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 -id). (let* ((s
9500: 74 65 70 73 2d 64 61 74 61 20 20 28 72 6d 74 3a teps-data (rmt:
9510: 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
9520: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
9530: 64 29 29 0a 09 20 28 63 6f 6d 70 72 73 74 65 70 d)).. (comprstep
9540: 73 20 20 28 74 65 73 74 73 3a 70 72 6f 63 65 73 s (tests:proces
9550: 73 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 73 74 s-steps-table st
9560: 65 70 73 2d 64 61 74 61 29 29 29 20 3b 3b 20 28 eps-data))) ;; (
9570: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
9580: 62 3a 67 65 74 2d 73 74 65 70 73 2d 74 61 62 6c b:get-steps-tabl
9590: 65 20 23 66 20 74 65 73 74 2d 69 64 20 77 6f 72 e #f test-id wor
95a0: 6b 2d 61 72 65 61 3a 20 77 6f 72 6b 2d 61 72 65 k-area: work-are
95b0: 61 29 29 29 0a 20 20 20 20 28 6d 61 70 20 28 6c a))). (map (l
95c0: 61 6d 62 64 61 20 28 78 29 0a 09 20 20 20 3b 3b ambda (x).. ;;
95d0: 20 74 61 6b 65 20 61 64 76 61 6e 74 61 67 65 20 take advantage
95e0: 6f 66 20 74 68 65 20 5c 6e 20 6f 6e 20 74 69 6d of the \n on tim
95f0: 65 2d 3e 73 74 72 69 6e 67 0a 09 20 20 20 28 76 e->string.. (v
9600: 65 63 74 6f 72 0a 09 20 20 20 20 28 76 65 63 74 ector.. (vect
9610: 6f 72 2d 72 65 66 20 78 20 30 29 0a 09 20 20 20 or-ref x 0)..
9620: 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f (let ((s (vecto
9630: 72 2d 72 65 66 20 78 20 31 29 29 29 0a 09 20 20 r-ref x 1)))..
9640: 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f (if (number?
9650: 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d s)(seconds->tim
9660: 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 0a e-string s) s)).
9670: 09 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 . (let ((s (v
9680: 65 63 74 6f 72 2d 72 65 66 20 78 20 32 29 29 29 ector-ref x 2)))
9690: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d .. (if (num
96a0: 62 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d ber? s)(seconds-
96b0: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 >time-string s)
96c0: 73 29 29 0a 09 20 20 20 20 28 76 65 63 74 6f 72 s)).. (vector
96d0: 2d 72 65 66 20 78 20 33 29 20 20 20 20 3b 3b 20 -ref x 3) ;;
96e0: 73 74 61 74 75 73 0a 09 20 20 20 20 28 76 65 63 status.. (vec
96f0: 74 6f 72 2d 72 65 66 20 78 20 34 29 0a 09 20 20 tor-ref x 4)..
9700: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
9710: 35 29 20 20 3b 3b 20 74 69 6d 65 20 64 65 6c 74 5) ;; time delt
9720: 61 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 a.. (vector-r
9730: 65 66 20 78 20 36 29 29 29 0a 09 20 28 73 6f 72 ef x 6))).. (sor
9740: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 t (hash-table-va
9750: 6c 75 65 73 20 63 6f 6d 70 72 73 74 65 70 73 29 lues comprsteps)
9760: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
9770: 20 28 61 20 62 29 0a 09 09 20 28 6c 65 74 20 28 (a b)... (let (
9780: 28 74 69 6d 65 2d 61 20 28 76 65 63 74 6f 72 2d (time-a (vector-
9790: 72 65 66 20 61 20 31 29 29 0a 09 09 20 20 20 20 ref a 1))...
97a0: 20 20 20 28 74 69 6d 65 2d 62 20 28 76 65 63 74 (time-b (vect
97b0: 6f 72 2d 72 65 66 20 62 20 31 29 29 29 0a 09 09 or-ref b 1)))...
97c0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d (if (and (num
97d0: 62 65 72 3f 20 74 69 6d 65 2d 61 29 28 6e 75 6d ber? time-a)(num
97e0: 62 65 72 3f 20 74 69 6d 65 2d 62 29 29 0a 09 09 ber? time-b))...
97f0: 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 74 69 (if (< ti
9800: 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 me-a time-b)....
9810: 20 20 20 23 74 0a 09 09 09 20 20 20 28 69 66 20 #t.... (if
9820: 28 65 71 3f 20 74 69 6d 65 2d 61 20 74 69 6d 65 (eq? time-a time
9830: 2d 62 29 0a 09 09 09 20 20 20 20 20 20 20 28 73 -b).... (s
9840: 74 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 28 76 tring<? (conc (v
9850: 65 63 74 6f 72 2d 72 65 66 20 61 20 32 29 29 0a ector-ref a 2)).
9860: 09 09 09 09 09 20 28 63 6f 6e 63 20 28 76 65 63 ..... (conc (vec
9870: 74 6f 72 2d 72 65 66 20 62 20 32 29 29 29 0a 09 tor-ref b 2)))..
9880: 09 09 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 .. #f))...
9890: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c 3f (string<?
98a0: 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 29 28 63 (conc time-a)(c
98b0: 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 29 29 29 onc time-b))))))
98c0: 29 29 29 0a 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 )))...;; summari
98d0: 7a 65 20 74 65 73 74 20 69 6e 20 74 6f 20 61 20 ze test in to a
98e0: 66 69 6c 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 file test-summar
98f0: 79 2e 68 74 6d 6c 20 69 6e 20 74 68 65 20 74 65 y.html in the te
9900: 73 74 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b 0a st directory.;;.
9910: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 (define (tests:s
9920: 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 20 72 75 ummarize-test ru
9930: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
9940: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 (let* ((test-dat
9950: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d (rmt:get-test-
9960: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
9970: 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 73 d test-id)).. (s
9980: 74 65 70 73 2d 64 61 74 20 28 72 6d 74 3a 67 65 teps-dat (rmt:ge
9990: 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 t-steps-for-test
99a0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
99b0: 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 ).. (test-name (
99c0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
99d0: 6e 61 6d 65 20 74 65 73 74 2d 64 61 74 29 29 0a name test-dat)).
99e0: 09 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 . (item-path (db
99f0: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
9a00: 61 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a 09 ath test-dat))..
9a10: 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 64 62 3a (full-name (db:
9a20: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
9a30: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
9a40: 65 6d 2d 70 61 74 68 29 29 0a 09 20 28 6f 75 70 em-path)).. (oup
9a50: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 (open-out
9a60: 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 28 put-file (conc (
9a70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
9a80: 69 72 20 74 65 73 74 2d 64 61 74 29 20 22 2f 74 ir test-dat) "/t
9a90: 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c est-summary.html
9aa0: 22 29 29 29 0a 09 20 28 73 74 61 74 75 73 20 20 "))).. (status
9ab0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
9ac0: 74 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 74 tatus test-dat
9ad0: 29 29 0a 09 20 28 63 6f 6c 6f 72 20 20 20 20 20 )).. (color
9ae0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
9af0: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
9b00: 61 74 75 73 29 29 0a 09 20 28 6c 6f 67 66 20 20 atus)).. (logf
9b10: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
9b20: 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 65 73 74 -final_logf test
9b30: 2d 64 61 74 29 29 0a 09 20 28 73 74 65 70 73 2d -dat)).. (steps-
9b40: 64 61 74 20 28 74 65 73 74 73 3a 67 65 74 2d 63 dat (tests:get-c
9b50: 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 ompressed-steps
9b60: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
9b70: 29 0a 20 20 20 20 3b 3b 20 28 64 63 6f 6d 6d 6f ). ;; (dcommo
9b80: 6e 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 n:get-compressed
9b90: 2d 73 74 65 70 73 20 23 66 20 31 20 33 30 30 34 -steps #f 1 3004
9ba0: 35 29 0a 20 20 20 20 3b 3b 20 28 23 28 22 77 61 5). ;; (#("wa
9bb0: 73 74 69 6e 67 5f 74 69 6d 65 22 20 22 32 33 3a sting_time" "23:
9bc0: 33 36 3a 31 33 22 20 22 32 33 3a 33 36 3a 32 31 36:13" "23:36:21
9bd0: 22 20 22 30 22 20 22 38 2e 30 73 22 20 22 77 61 " "0" "8.0s" "wa
9be0: 73 74 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 29 sting_time.log")
9bf0: 29 0a 0a 20 20 20 20 28 73 3a 6f 75 74 70 75 74 ).. (s:output
9c00: 2d 6e 65 77 0a 20 20 20 20 20 6f 75 70 0a 20 20 -new. oup.
9c10: 20 20 20 28 73 3a 68 74 6d 6c 0a 20 20 20 20 20 (s:html.
9c20: 20 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 (s:title "Summa
9c30: 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 ry for " full-na
9c40: 6d 65 29 0a 20 20 20 20 20 20 28 73 3a 62 6f 64 me). (s:bod
9c50: 79 20 0a 20 20 20 20 20 20 20 28 73 3a 68 32 20 y . (s:h2
9c60: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 66 "Summary for " f
9c70: 75 6c 6c 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 ull-name).
9c80: 20 28 73 3a 74 61 62 6c 65 20 27 63 65 6c 6c 73 (s:table 'cells
9c90: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
9ca0: 65 72 20 22 31 22 0a 09 28 73 3a 74 72 20 28 73 er "1"..(s:tr (s
9cb0: 3a 74 64 20 22 72 75 6e 20 69 64 22 29 20 20 20 :td "run id")
9cc0: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
9cd0: 65 74 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 74 et-run_id test
9ce0: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 73 -dat)).. (s
9cf0: 3a 74 64 20 22 74 65 73 74 20 69 64 22 29 20 20 :td "test id")
9d00: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
9d10: 65 74 2d 69 64 20 20 20 20 20 20 20 74 65 73 74 et-id test
9d20: 2d 64 61 74 29 29 29 0a 09 28 73 3a 74 72 20 28 -dat)))..(s:tr (
9d30: 73 3a 74 64 20 22 74 65 73 74 6e 61 6d 65 22 29 s:td "testname")
9d40: 20 28 73 3a 74 64 20 74 65 73 74 2d 6e 61 6d 65 (s:td test-name
9d50: 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 22 ).. (s:td "
9d60: 69 74 65 6d 70 61 74 68 22 29 20 28 73 3a 74 64 itempath") (s:td
9d70: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 28 73 item-path))..(s
9d80: 3a 74 72 20 28 73 3a 74 64 20 22 73 74 61 74 65 :tr (s:td "state
9d90: 22 29 20 20 20 20 28 73 3a 74 64 20 28 64 62 3a ") (s:td (db:
9da0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 test-get-state
9db0: 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 test-dat))..
9dc0: 20 20 20 20 28 73 3a 74 64 20 22 73 74 61 74 75 (s:td "statu
9dd0: 73 22 29 20 20 20 28 73 3a 74 64 20 28 73 3a 61 s") (s:td (s:a
9de0: 20 27 68 72 65 66 20 6c 6f 67 66 20 28 73 3a 66 'href logf (s:f
9df0: 6f 6e 74 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f 72 ont 'color color
9e00: 20 73 74 61 74 75 73 29 29 29 29 0a 09 28 73 3a status))))..(s:
9e10: 74 72 20 28 73 3a 74 64 20 22 54 65 73 74 44 61 tr (s:td "TestDa
9e20: 74 65 22 29 20 28 73 3a 74 64 20 28 73 65 63 6f te") (s:td (seco
9e30: 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 nds->work-week/d
9e40: 61 79 2d 74 69 6d 65 20 0a 09 09 09 09 20 20 20 ay-time .....
9e50: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
9e60: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 -event_time test
9e70: 2d 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 -dat))).. (
9e80: 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 s:td "Duration")
9e90: 20 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d (s:td (seconds-
9ea0: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 64 62 3a >hr-min-sec (db:
9eb0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 test-get-run_dur
9ec0: 61 74 69 6f 6e 20 74 65 73 74 2d 64 61 74 29 29 ation test-dat))
9ed0: 29 29 29 0a 20 20 20 20 20 20 20 28 73 3a 68 33 ))). (s:h3
9ee0: 20 22 4c 6f 67 20 66 69 6c 65 73 22 29 0a 20 20 "Log files").
9ef0: 20 20 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 27 (s:table..'
9f00: 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 20 cellspacing "0"
9f10: 27 62 6f 72 64 65 72 20 22 31 22 0a 09 28 73 3a 'border "1"..(s:
9f20: 74 72 20 28 73 3a 74 64 20 22 46 69 6e 61 6c 20 tr (s:td "Final
9f30: 6c 6f 67 22 29 28 73 3a 74 64 20 28 73 3a 61 20 log")(s:td (s:a
9f40: 27 68 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 29 'href logf logf)
9f50: 29 29 29 0a 20 20 20 20 20 20 20 28 73 3a 74 61 ))). (s:ta
9f60: 62 6c 65 0a 09 27 63 65 6c 6c 73 70 61 63 69 6e ble..'cellspacin
9f70: 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 g "0" 'border "1
9f80: 22 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 22 "..(s:tr (s:td "
9f90: 53 74 65 70 20 4e 61 6d 65 22 29 28 73 3a 74 64 Step Name")(s:td
9fa0: 20 22 53 74 61 72 74 22 29 28 73 3a 74 64 20 22 "Start")(s:td "
9fb0: 45 6e 64 22 29 28 73 3a 74 64 20 22 53 74 61 74 End")(s:td "Stat
9fc0: 75 73 22 29 28 73 3a 74 64 20 22 44 75 72 61 74 us")(s:td "Durat
9fd0: 69 6f 6e 22 29 28 73 3a 74 64 20 22 4c 6f 67 20 ion")(s:td "Log
9fe0: 46 69 6c 65 22 29 29 0a 09 28 6d 61 70 20 28 6c File"))..(map (l
9ff0: 61 6d 62 64 61 20 28 73 74 65 70 2d 64 61 74 29 ambda (step-dat)
a000: 0a 09 20 20 20 20 20 20 20 28 73 3a 74 72 20 28 .. (s:tr (
a010: 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
a020: 74 61 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e 61 table-get-stepna
a030: 6d 65 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 me step-dat))...
a040: 20 20 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a (s:td (tdb:
a050: 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d steps-table-get-
a060: 73 74 61 72 74 20 20 20 20 73 74 65 70 2d 64 61 start step-da
a070: 74 29 29 0a 09 09 20 20 20 20 20 28 73 3a 74 64 t))... (s:td
a080: 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c (tdb:steps-tabl
a090: 65 2d 67 65 74 2d 65 6e 64 20 20 20 20 20 20 73 e-get-end s
a0a0: 74 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 20 tep-dat))...
a0b0: 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 (s:td (tdb:step
a0c0: 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 74 s-table-get-stat
a0d0: 75 73 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a us step-dat)).
a0e0: 09 09 20 20 20 20 20 28 73 3a 74 64 20 28 74 64 .. (s:td (td
a0f0: 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 b:steps-table-ge
a100: 74 2d 72 75 6e 74 69 6d 65 20 20 73 74 65 70 2d t-runtime step-
a110: 64 61 74 29 29 0a 09 09 20 20 20 20 20 28 73 3a dat))... (s:
a120: 74 64 20 28 6c 65 74 20 28 28 73 74 65 70 2d 6c td (let ((step-l
a130: 6f 67 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 og (tdb:steps-ta
a140: 62 6c 65 2d 67 65 74 2d 6c 6f 67 2d 66 69 6c 65 ble-get-log-file
a150: 20 73 74 65 70 2d 64 61 74 29 29 29 0a 09 09 09 step-dat)))....
a160: 20 20 20 20 20 28 73 3a 61 20 27 68 72 65 66 20 (s:a 'href
a170: 73 74 65 70 2d 6c 6f 67 20 73 74 65 70 2d 6c 6f step-log step-lo
a180: 67 29 29 29 29 29 0a 09 20 20 20 20 20 73 74 65 g))))).. ste
a190: 70 73 2d 64 61 74 29 29 0a 09 29 29 29 0a 20 20 ps-dat))..))).
a1a0: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
a1b0: 70 6f 72 74 20 6f 75 70 29 29 29 0a 09 20 20 0a port oup))).. .
a1c0: 09 20 20 0a 3b 3b 20 4d 55 53 54 20 42 45 20 43 . .;; MUST BE C
a1d0: 41 4c 4c 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b 0a ALLED local!.;;.
a1e0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
a1f0: 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 est-get-paths-ma
a200: 74 63 68 69 6e 67 20 6b 65 79 6e 61 6d 65 73 20 tching keynames
a210: 74 61 72 67 65 74 20 66 6e 61 6d 65 70 61 74 74 target fnamepatt
a220: 20 23 21 6b 65 79 20 28 72 65 73 20 27 28 29 29 #!key (res '())
a230: 29 0a 20 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 65 ). ;; BUG: Move
a240: 20 74 68 65 20 76 61 6c 75 65 73 20 64 65 72 69 the values deri
a250: 76 65 64 20 66 72 6f 6d 20 61 72 67 73 20 74 6f ved from args to
a260: 20 70 61 72 61 6d 65 74 65 72 73 20 61 6e 64 20 parameters and
a270: 70 75 73 68 20 74 6f 20 6d 65 67 61 74 65 73 74 push to megatest
a280: 2e 73 63 6d 0a 20 20 28 6c 65 74 2a 20 28 28 74 .scm. (let* ((t
a290: 65 73 74 70 61 74 74 20 20 20 28 6f 72 20 28 61 estpatt (or (a
a2a0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 rgs:get-arg "-te
a2b0: 73 74 70 61 74 74 22 29 28 61 72 67 73 3a 67 65 stpatt")(args:ge
a2c0: 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 t-arg "-testpatt
a2d0: 22 29 20 22 25 22 29 29 0a 09 20 28 73 74 61 74 ") "%")).. (stat
a2e0: 65 70 61 74 74 20 20 28 6f 72 20 28 61 72 67 73 epatt (or (args
a2f0: 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 :get-arg "-state
a300: 22 29 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 ") (args:get-a
a310: 72 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 20 rg ":state")
a320: 22 25 22 29 29 0a 09 20 28 73 74 61 74 75 73 70 "%")).. (statusp
a330: 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 att (or (args:ge
a340: 74 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 t-arg "-status")
a350: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
a360: 22 3a 73 74 61 74 75 73 22 29 20 20 20 22 25 22 ":status") "%"
a370: 29 29 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 20 )).. (runname
a380: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
a390: 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 20 28 rg "-runname") (
a3a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
a3b0: 75 6e 6e 61 6d 65 22 29 20 20 22 25 22 29 29 0a unname") "%")).
a3c0: 09 20 28 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 . (paths-from-db
a3d0: 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 (rmt:test-get-p
a3e0: 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 aths-matching-ke
a3f0: 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 ynames-target-ne
a400: 77 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 w keynames targe
a410: 74 20 72 65 73 0a 09 09 09 09 09 74 65 73 74 70 t res......testp
a420: 61 74 74 0a 09 09 09 09 09 73 74 61 74 65 70 61 att......statepa
a430: 74 74 0a 09 09 09 09 09 73 74 61 74 75 73 70 61 tt......statuspa
a440: 74 74 0a 09 09 09 09 09 72 75 6e 6e 61 6d 65 29 tt......runname)
a450: 29 29 0a 20 20 20 20 28 69 66 20 66 6e 61 6d 65 )). (if fname
a460: 70 61 74 74 0a 09 28 61 70 70 6c 79 20 61 70 70 patt..(apply app
a470: 65 6e 64 20 0a 09 20 20 20 20 20 20 20 28 6d 61 end .. (ma
a480: 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 p (lambda (p)...
a490: 20 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 (if (direc
a4a0: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 29 0a tory-exists? p).
a4b0: 09 09 09 20 20 28 6c 65 74 20 28 28 67 6c 6f 62 ... (let ((glob
a4c0: 2d 71 75 65 72 79 20 28 63 6f 6e 63 20 70 20 22 -query (conc p "
a4d0: 2f 22 20 66 6e 61 6d 65 70 61 74 74 29 29 29 0a /" fnamepatt))).
a4e0: 09 09 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ... (handle-e
a4f0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 xceptions.....ex
a500: 6e 0a 09 09 09 09 28 77 69 74 68 2d 69 6e 70 75 n.....(with-inpu
a510: 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 09 09 09 t-from-pipe.....
a520: 20 20 20 20 28 63 6f 6e 63 20 22 65 63 68 6f 20 (conc "echo
a530: 22 20 67 6c 6f 62 2d 71 75 65 72 79 29 0a 09 09 " glob-query)...
a540: 09 09 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 20 .. read-lines)
a550: 20 3b 3b 20 77 65 20 61 72 65 6e 27 74 20 67 6f ;; we aren't go
a560: 69 6e 67 20 74 6f 20 74 72 79 20 74 6f 6f 20 68 ing to try too h
a570: 61 72 64 2e 20 49 66 20 67 6c 6f 62 20 62 72 65 ard. If glob bre
a580: 61 6b 73 20 69 74 20 69 73 20 6c 69 6b 65 6c 79 aks it is likely
a590: 20 62 65 63 61 75 73 65 20 73 6f 6d 65 6f 6e 65 because someone
a5a0: 20 74 72 69 65 64 20 74 6f 20 64 6f 20 2a 2f 2a tried to do */*
a5b0: 2f 2a 2e 6c 6f 67 20 6f 72 20 73 69 6d 69 6c 61 /*.log or simila
a5c0: 72 0a 09 09 09 20 20 20 20 20 20 28 67 6c 6f 62 r.... (glob
a5d0: 20 67 6c 6f 62 2d 71 75 65 72 79 29 29 29 0a 09 glob-query)))..
a5e0: 09 09 20 20 27 28 29 29 29 0a 09 09 20 20 20 20 .. '()))...
a5f0: 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 0a paths-from-db)).
a600: 09 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 .paths-from-db))
a610: 29 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b 3d )..... .;;=
a620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a660: 3d 3d 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 20 =====.;; Gather
a670: 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 2f 74 data from test/t
a680: 61 73 6b 20 73 70 65 63 69 66 69 63 61 74 69 6f ask specificatio
a690: 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
a6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
a6e0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
a6f0: 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 et-valid-tests t
a700: 65 73 74 73 64 69 72 20 74 65 73 74 2d 70 61 74 estsdir test-pat
a710: 74 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 74 ts) ;; #!key (t
a720: 65 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a est-names '())).
a730: 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 ;; (let ((test
a740: 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 65 s (glob (conc te
a750: 73 74 73 64 69 72 20 22 2f 74 65 73 74 73 2f 2a stsdir "/tests/*
a760: 22 29 29 29 29 20 3b 3b 20 22 20 28 73 74 72 69 ")))) ;; " (stri
a770: 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 ng-translate pat
a780: 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a 3b t "%" "*"))))).;
a790: 3b 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 ; (set! test
a7a0: 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
a7b0: 61 20 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 a (test)(file-ex
a7c0: 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 ists? (conc test
a7d0: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
a7e0: 29 20 74 65 73 74 73 29 29 0a 3b 3b 20 20 20 20 ) tests)).;;
a7f0: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
a800: 74 65 73 0a 3b 3b 20 20 20 20 20 20 28 66 69 6c tes.;; (fil
a810: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
a820: 74 6e 61 6d 65 29 0a 3b 3b 20 09 20 20 20 20 20 tname).;; .
a830: 20 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 (tests:match t
a840: 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 est-patts testna
a850: 6d 65 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 me #f)).;; .
a860: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 (map (lambda (t
a870: 65 73 74 70 29 0a 3b 3b 20 09 09 20 20 20 20 28 estp).;; .. (
a880: 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c last (string-spl
a890: 69 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a it testp "/"))).
a8a0: 3b 3b 20 09 09 20 20 74 65 73 74 73 29 29 29 29 ;; .. tests))))
a8b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
a8c0: 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 2d s:get-test-path-
a8d0: 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 from-environment
a8e0: 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 ). (if (and (ge
a8f0: 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 tenv "MT_LINKTRE
a900: 45 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 E").. (getenv
a910: 22 4d 54 5f 54 41 52 47 45 54 22 29 0a 09 20 20 "MT_TARGET")..
a920: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (getenv "MT_RUN
a930: 4e 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 65 NAME").. (gete
a940: 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 nv "MT_TEST_NAME
a950: 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 ").. (getenv "
a960: 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 0a 20 MT_ITEMPATH")).
a970: 20 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 65 (conc (gete
a980: 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 nv "MT_LINKTREE"
a990: 29 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 ) "/".. (get
a9a0: 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 env "MT_TARGET")
a9b0: 20 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 "/".. (ge
a9c0: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 tenv "MT_RUNNAME
a9d0: 22 29 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 ") "/".. (g
a9e0: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
a9f0: 41 4d 45 22 29 20 22 2f 22 0a 09 20 20 20 20 28 AME") "/".. (
aa00: 69 66 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 if (or (getenv "
aa10: 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 0a 09 09 MT_ITEMPATH")...
aa20: 20 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 (not (string
aa30: 3d 3f 20 22 22 20 28 67 65 74 65 6e 76 20 22 4d =? "" (getenv "M
aa40: 54 5f 49 54 45 4d 50 41 54 48 22 29 29 29 29 0a T_ITEMPATH")))).
aa50: 09 09 28 63 6f 6e 63 20 22 2f 22 20 28 67 65 74 ..(conc "/" (get
aa60: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
aa70: 22 29 29 29 29 0a 20 20 20 20 20 20 23 66 29 29 ")))). #f))
aa80: 0a 0a 3b 3b 20 69 66 20 2e 74 65 73 74 63 6f 6e ..;; if .testcon
aa90: 66 69 67 20 65 78 69 73 74 73 20 69 6e 20 74 65 fig exists in te
aaa0: 73 74 20 64 69 72 65 63 74 6f 72 79 20 72 65 61 st directory rea
aab0: 64 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a d and return it.
aac0: 3b 3b 20 65 6c 73 65 20 69 66 20 68 61 76 65 20 ;; else if have
aad0: 63 61 63 68 65 64 20 63 6f 70 79 20 69 6e 20 2a cached copy in *
aae0: 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 72 65 74 testconfigs* ret
aaf0: 75 72 6e 20 69 74 20 49 46 46 20 74 68 65 72 65 urn it IFF there
ab00: 20 69 73 20 61 20 73 65 63 74 69 6f 6e 20 22 68 is a section "h
ab10: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 0a 3b 3b ave fulldata".;;
ab20: 20 65 6c 73 65 20 72 65 61 64 20 74 68 65 20 74 else read the t
ab30: 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 0a 3b estconfig file.;
ab40: 3b 20 20 20 69 66 20 68 61 76 65 20 70 61 74 68 ; if have path
ab50: 20 74 6f 20 74 65 73 74 20 64 69 72 65 63 74 6f to test directo
ab60: 72 79 20 73 61 76 65 20 74 68 65 20 63 6f 6e 66 ry save the conf
ab70: 69 67 20 61 73 20 2e 74 65 73 74 63 6f 6e 66 69 ig as .testconfi
ab80: 67 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a g and return it.
ab90: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
aba0: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
abb0: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
abc0: 72 65 67 69 73 74 72 79 20 73 79 73 74 65 6d 2d registry system-
abd0: 61 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 66 allowed #!key (f
abe0: 6f 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 29 orce-create #f))
abf0: 0a 20 20 28 6c 65 74 2a 20 28 28 63 61 63 68 65 . (let* ((cache
ac00: 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 3a 67 -path (tests:g
ac10: 65 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f et-test-path-fro
ac20: 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a m-environment)).
ac30: 09 20 28 63 61 63 68 65 2d 66 69 6c 65 20 20 20 . (cache-file
ac40: 28 61 6e 64 20 63 61 63 68 65 2d 70 61 74 68 20 (and cache-path
ac50: 28 63 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 (conc cache-path
ac60: 20 22 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 "/.testconfig")
ac70: 29 29 0a 09 20 28 63 61 63 68 65 2d 65 78 69 73 )).. (cache-exis
ac80: 74 73 20 28 61 6e 64 20 63 61 63 68 65 2d 66 69 ts (and cache-fi
ac90: 6c 65 0a 09 09 09 20 20 20 20 28 6e 6f 74 20 66 le.... (not f
aca0: 6f 72 63 65 2d 63 72 65 61 74 65 29 20 20 3b 3b orce-create) ;;
acb0: 20 69 66 20 66 6f 72 63 65 2d 63 72 65 61 74 65 if force-create
acc0: 20 74 68 65 6e 20 70 72 65 74 65 6e 64 20 74 68 then pretend th
acd0: 65 72 65 20 69 73 20 6e 6f 20 63 61 63 68 65 20 ere is no cache
ace0: 74 6f 20 72 65 61 64 0a 09 09 09 20 20 20 20 28 to read.... (
acf0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 61 63 file-exists? cac
ad00: 68 65 2d 66 69 6c 65 29 29 29 0a 09 20 28 63 61 he-file))).. (ca
ad10: 63 68 65 64 2d 64 61 74 20 20 20 28 69 66 20 28 ched-dat (if (
ad20: 61 6e 64 20 28 6e 6f 74 20 66 6f 72 63 65 2d 63 and (not force-c
ad30: 72 65 61 74 65 29 0a 09 09 09 09 63 61 63 68 65 reate).....cache
ad40: 2d 65 78 69 73 74 73 29 0a 09 09 09 20 20 20 28 -exists).... (
ad50: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
ad60: 73 0a 09 09 09 20 20 20 20 65 78 6e 0a 09 09 09 s.... exn....
ad70: 20 20 20 20 23 66 20 3b 3b 20 61 6e 79 20 69 73 #f ;; any is
ad80: 73 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 20 sues, just give
ad90: 75 70 20 77 69 74 68 20 74 68 65 20 63 61 63 68 up with the cach
ada0: 65 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 72 ed version and r
adb0: 65 2d 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 e-read.... (c
adc0: 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 73 onfigf:read-alis
add0: 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 0a 09 t cache-file))..
ade0: 09 09 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 .. #f))). (
adf0: 69 66 20 63 61 63 68 65 64 2d 64 61 74 0a 09 63 if cached-dat..c
ae00: 61 63 68 65 64 2d 64 61 74 0a 09 28 6c 65 74 20 ached-dat..(let
ae10: 28 28 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c ((dat (hash-tabl
ae20: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 e-ref/default *t
ae30: 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 estconfigs* test
ae40: 2d 6e 61 6d 65 20 23 66 29 29 29 0a 09 20 20 28 -name #f))).. (
ae50: 69 66 20 28 61 6e 64 20 20 64 61 74 20 3b 3b 20 if (and dat ;;
ae60: 68 61 76 65 20 61 20 6c 6f 63 61 6c 6c 79 20 63 have a locally c
ae70: 61 63 68 65 64 20 76 65 72 73 69 6f 6e 0a 09 09 ached version...
ae80: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
ae90: 72 65 66 2f 64 65 66 61 75 6c 74 20 64 61 74 20 ref/default dat
aea0: 22 68 61 76 65 20 66 75 6c 6c 64 61 74 61 22 20 "have fulldata"
aeb0: 23 66 29 29 20 3b 3b 20 6d 61 72 6b 65 64 20 61 #f)) ;; marked a
aec0: 73 20 67 6f 6f 64 20 64 61 74 61 3f 0a 09 20 20 s good data?..
aed0: 20 20 20 20 64 61 74 0a 09 20 20 20 20 20 20 3b dat.. ;
aee0: 3b 20 6e 6f 20 63 61 63 68 65 64 20 64 61 74 61 ; no cached data
aef0: 20 61 76 61 69 6c 61 62 6c 65 0a 09 20 20 20 20 available..
af00: 20 20 28 6c 65 74 2a 20 28 28 74 72 65 67 20 20 (let* ((treg
af10: 20 20 20 20 20 20 20 28 6f 72 20 74 65 73 74 2d (or test-
af20: 72 65 67 69 73 74 72 79 0a 09 09 09 09 20 20 20 registry.....
af30: 20 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 61 (tests:get-a
af40: 6c 6c 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 ll)))... (te
af50: 73 74 2d 70 61 74 68 20 20 20 20 28 6f 72 20 28 st-path (or (
af60: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
af70: 65 66 61 75 6c 74 20 74 72 65 67 20 74 65 73 74 efault treg test
af80: 2d 6e 61 6d 65 20 23 66 29 0a 09 09 09 09 20 20 -name #f).....
af90: 20 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 (conc *topp
afa0: 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 ath* "/tests/" t
afb0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 est-name)))...
afc0: 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 (test-configf
afd0: 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 (conc test-path
afe0: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
aff0: 0a 09 09 20 20 20 20 20 28 74 65 73 74 65 78 69 ... (testexi
b000: 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 sts (and (file
b010: 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f -exists? test-co
b020: 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 nfigf)(file-read
b030: 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f -access? test-co
b040: 6e 66 69 67 66 29 29 29 0a 09 09 20 20 20 20 20 nfigf)))...
b050: 28 74 63 66 67 20 20 20 20 20 20 20 20 20 28 69 (tcfg (i
b060: 66 20 74 65 73 74 65 78 69 73 74 73 0a 09 09 09 f testexists....
b070: 09 20 20 20 20 20 20 20 28 72 65 61 64 2d 63 6f . (read-co
b080: 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 nfig test-config
b090: 66 20 23 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f f #f system-allo
b0a0: 77 65 64 0a 09 09 09 09 09 09 20 20 20 20 65 6e wed....... en
b0b0: 76 69 72 6f 6e 2d 70 61 74 74 3a 20 28 69 66 20 viron-patt: (if
b0c0: 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 system-allowed..
b0d0: 09 09 09 09 09 09 09 20 20 20 20 20 20 22 70 72 ....... "pr
b0e0: 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 e-launch-env-var
b0f0: 73 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 s".........
b100: 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 #f)).....
b110: 20 23 66 29 29 29 0a 09 09 28 69 66 20 28 61 6e #f)))...(if (an
b120: 64 20 74 63 66 67 20 63 61 63 68 65 2d 66 69 6c d tcfg cache-fil
b130: 65 29 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 e) (hash-table-s
b140: 65 74 21 20 74 63 66 67 20 22 68 61 76 65 20 66 et! tcfg "have f
b150: 75 6c 6c 64 61 74 61 22 20 23 74 29 29 20 3b 3b ulldata" #t)) ;;
b160: 20 6d 61 72 6b 20 74 68 69 73 20 61 73 20 66 75 mark this as fu
b170: 6c 6c 79 20 72 65 61 64 20 64 61 74 61 0a 09 09 lly read data...
b180: 28 69 66 20 74 63 66 67 20 28 68 61 73 68 2d 74 (if tcfg (hash-t
b190: 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 63 able-set! *testc
b1a0: 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d 6e 61 6d onfigs* test-nam
b1b0: 65 20 74 63 66 67 29 29 0a 09 09 28 69 66 20 28 e tcfg))...(if (
b1c0: 61 6e 64 20 74 65 73 74 65 78 69 73 74 73 0a 09 and testexists..
b1d0: 09 09 20 63 61 63 68 65 2d 66 69 6c 65 0a 09 09 .. cache-file...
b1e0: 09 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 . (file-write-ac
b1f0: 63 65 73 73 3f 20 63 61 63 68 65 2d 70 61 74 68 cess? cache-path
b200: 29 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 ))... (let ((
b210: 74 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 tpath (conc cach
b220: 65 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f e-path "/.testco
b230: 6e 66 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 nfig")))...
b240: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
b250: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
b260: 67 2d 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 g-port* "Caching
b270: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 testconfig for
b280: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e " test-name " in
b290: 20 22 20 74 70 61 74 68 29 0a 09 09 20 20 20 20 " tpath)...
b2a0: 20 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 74 65 (configf:write
b2b0: 2d 61 6c 69 73 74 20 74 63 66 67 20 74 70 61 74 -alist tcfg tpat
b2c0: 68 29 29 29 0a 09 09 74 63 66 67 29 29 29 29 29 h)))...tcfg)))))
b2d0: 29 0a 20 20 0a 3b 3b 20 73 6f 72 74 20 74 65 73 ). .;; sort tes
b2e0: 74 73 20 62 79 20 70 72 69 6f 72 69 74 79 20 61 ts by priority a
b2f0: 6e 64 20 77 61 69 74 6f 6e 0a 3b 3b 20 4d 6f 76 nd waiton.;; Mov
b300: 65 20 74 65 73 74 20 73 70 65 63 69 66 69 63 20 e test specific
b310: 73 74 75 66 66 20 74 6f 20 61 20 74 65 73 74 20 stuff to a test
b320: 75 6e 69 74 20 46 49 58 4d 45 20 6f 6e 65 20 6f unit FIXME one o
b330: 66 20 74 68 65 73 65 20 64 61 79 73 0a 28 64 65 f these days.(de
b340: 66 69 6e 65 20 28 74 65 73 74 73 3a 73 6f 72 74 fine (tests:sort
b350: 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 -by-priority-and
b360: 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 -waiton test-rec
b370: 6f 72 64 73 29 0a 20 20 28 69 66 20 28 65 71 3f ords). (if (eq?
b380: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 69 7a (hash-table-siz
b390: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 20 e test-records)
b3a0: 30 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 0). '().
b3b0: 20 20 20 28 6c 65 74 2a 20 28 28 6d 75 6e 67 65 (let* ((munge
b3c0: 70 72 69 6f 72 69 74 79 20 28 6c 61 6d 62 64 61 priority (lambda
b3d0: 20 28 70 72 69 6f 72 69 74 79 29 0a 09 09 09 20 (priority)....
b3e0: 20 20 20 20 20 28 69 66 20 70 72 69 6f 72 69 74 (if priorit
b3f0: 79 0a 09 09 09 09 20 20 28 6c 65 74 20 28 28 74 y..... (let ((t
b400: 6d 70 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 mp (any->number
b410: 70 72 69 6f 72 69 74 79 29 29 29 0a 09 09 09 09 priority))).....
b420: 20 20 20 20 28 69 66 20 74 6d 70 20 74 6d 70 20 (if tmp tmp
b430: 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 (begin (debug:pr
b440: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
b450: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
b460: 62 61 64 20 70 72 69 6f 72 69 74 79 20 76 61 6c bad priority val
b470: 75 65 20 22 20 70 72 69 6f 72 69 74 79 20 22 2c ue " priority ",
b480: 20 75 73 69 6e 67 20 30 22 29 20 30 29 29 29 0a using 0") 0))).
b490: 09 09 09 09 20 20 30 29 29 29 0a 09 20 20 20 20 .... 0)))..
b4a0: 20 28 61 6c 6c 2d 74 65 73 74 73 20 20 20 20 20 (all-tests
b4b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
b4c0: 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 s test-records))
b4d0: 0a 09 20 20 20 20 20 28 61 6c 6c 2d 77 61 69 74 .. (all-wait
b4e0: 65 64 2d 6f 6e 20 20 28 6c 65 74 20 6c 6f 6f 70 ed-on (let loop
b4f0: 20 28 28 68 65 64 20 28 63 61 72 20 61 6c 6c 2d ((hed (car all-
b500: 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 74 61 tests))......(ta
b510: 6c 20 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 73 l (cdr all-tests
b520: 29 29 0a 09 09 09 09 09 28 72 65 73 20 27 28 29 ))......(res '()
b530: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 )).... (le
b540: 74 2a 20 28 28 74 72 65 63 20 20 20 20 28 68 61 t* ((trec (ha
b550: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
b560: 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 0a t-records hed)).
b570: 09 09 09 09 20 20 20 20 20 20 28 77 61 69 74 6f .... (waito
b580: 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 ns (or (tests:te
b590: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
b5a0: 6f 6e 73 20 74 72 65 63 29 20 27 28 29 29 29 29 ons trec) '())))
b5b0: 0a 09 09 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f ..... (if (null?
b5c0: 20 74 61 6c 29 0a 09 09 09 09 20 20 20 20 20 28 tal)..... (
b5d0: 61 70 70 65 6e 64 20 72 65 73 20 77 61 69 74 6f append res waito
b5e0: 6e 73 29 0a 09 09 09 09 20 20 20 20 20 28 6c 6f ns)..... (lo
b5f0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
b600: 20 74 61 6c 29 28 61 70 70 65 6e 64 20 72 65 73 tal)(append res
b610: 20 77 61 69 74 6f 6e 73 29 29 29 29 29 29 0a 09 waitons))))))..
b620: 20 20 20 20 20 28 73 6f 72 74 2d 66 6e 31 20 0a (sort-fn1 .
b630: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
b640: 61 20 62 29 0a 09 09 28 6c 65 74 2a 20 28 28 61 a b)...(let* ((a
b650: 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d -record (hash-
b660: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
b670: 65 63 6f 72 64 73 20 61 29 29 0a 09 09 20 20 20 ecords a))...
b680: 20 20 20 20 28 62 2d 72 65 63 6f 72 64 20 20 20 (b-record
b690: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
b6a0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 29 29 test-records b))
b6b0: 0a 09 09 20 20 20 20 20 20 20 28 61 2d 77 61 69 ... (a-wai
b6c0: 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 73 74 73 tons (or (tests
b6d0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
b6e0: 61 69 74 6f 6e 73 20 61 2d 72 65 63 6f 72 64 29 aitons a-record)
b6f0: 20 27 28 29 29 29 0a 09 09 20 20 20 20 20 20 20 '()))...
b700: 28 62 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 (b-waitons (or
b710: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
b720: 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 62 2d 72 -get-waitons b-r
b730: 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 ecord) '()))...
b740: 20 20 20 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 (a-config
b750: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
b760: 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ue-get-testconfi
b770: 67 20 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 09 g a-record))...
b780: 20 20 20 20 20 20 20 28 62 2d 63 6f 6e 66 69 67 (b-config
b790: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
b7a0: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
b7b0: 69 67 20 20 62 2d 72 65 63 6f 72 64 29 29 0a 09 ig b-record))..
b7c0: 09 20 20 20 20 20 20 20 28 61 2d 72 61 77 2d 70 . (a-raw-p
b7d0: 72 69 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b ri (config-look
b7e0: 75 70 20 61 2d 63 6f 6e 66 69 67 20 22 72 65 71 up a-config "req
b7f0: 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
b800: 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 20 20 rity"))...
b810: 20 28 62 2d 72 61 77 2d 70 72 69 20 20 28 63 6f (b-raw-pri (co
b820: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 62 2d 63 6f nfig-lookup b-co
b830: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
b840: 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 ts" "priority"))
b850: 0a 09 09 20 20 20 20 20 20 20 28 61 2d 70 72 69 ... (a-pri
b860: 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f ority (mungeprio
b870: 72 69 74 79 20 61 2d 72 61 77 2d 70 72 69 29 29 rity a-raw-pri))
b880: 0a 09 09 20 20 20 20 20 20 20 28 62 2d 70 72 69 ... (b-pri
b890: 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f ority (mungeprio
b8a0: 72 69 74 79 20 62 2d 72 61 77 2d 70 72 69 29 29 rity b-raw-pri))
b8b0: 29 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 )... (tests:tes
b8c0: 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 tqueue-set-prior
b8d0: 69 74 79 21 20 61 2d 72 65 63 6f 72 64 20 61 2d ity! a-record a-
b8e0: 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 28 74 priority)... (t
b8f0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
b900: 65 74 2d 70 72 69 6f 72 69 74 79 21 20 62 2d 72 et-priority! b-r
b910: 65 63 6f 72 64 20 62 2d 70 72 69 6f 72 69 74 79 ecord b-priority
b920: 29 0a 09 09 20 20 3b 3b 20 28 64 65 62 75 67 3a )... ;; (debug:
b930: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
b940: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 3d 22 20 -log-port* "a="
b950: 61 20 22 2c 20 62 3d 22 20 62 20 22 2c 20 61 2d a ", b=" b ", a-
b960: 77 61 69 74 6f 6e 73 3d 22 20 61 2d 77 61 69 74 waitons=" a-wait
b970: 6f 6e 73 20 22 2c 20 62 2d 77 61 69 74 6f 6e 73 ons ", b-waitons
b980: 3d 22 20 62 2d 77 61 69 74 6f 6e 73 29 0a 09 09 =" b-waitons)...
b990: 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 3b 3b 20 (cond... ;;
b9a0: 69 73 20 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 is ... ((membe
b9b0: 72 20 61 20 62 2d 77 61 69 74 6f 6e 73 29 20 20 r a b-waitons)
b9c0: 20 20 20 20 20 20 20 20 3b 3b 20 69 73 20 62 20 ;; is b
b9d0: 77 61 69 74 69 6e 67 20 6f 6e 20 61 3f 0a 09 09 waiting on a?...
b9e0: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
b9f0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
ba00: 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 31 22 og-port* "case1"
ba10: 29 0a 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 )... #t)...
ba20: 20 28 28 6d 65 6d 62 65 72 20 62 20 61 2d 77 61 ((member b a-wa
ba30: 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 itons)
ba40: 3b 3b 20 69 73 20 61 20 77 61 69 74 69 6e 67 20 ;; is a waiting
ba50: 6f 6e 20 62 3f 0a 09 09 20 20 20 20 3b 3b 20 28 on b?... ;; (
ba60: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
ba70: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ba80: 20 22 63 61 73 65 32 22 29 0a 09 09 20 20 20 20 "case2")...
ba90: 23 66 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 #f)... ((and (
baa0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 not (null? a-wai
bab0: 74 6f 6e 73 29 29 20 20 3b 3b 20 62 6f 74 68 20 tons)) ;; both
bac0: 68 61 76 65 20 77 61 69 74 6f 6e 73 20 2d 20 64 have waitons - d
bad0: 6f 20 6e 6f 74 20 64 69 73 74 75 72 62 0a 09 09 o not disturb...
bae0: 09 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d . (not (null? b-
baf0: 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 waitons)))...
bb00: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
bb10: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
bb20: 70 6f 72 74 2a 20 22 63 61 73 65 32 2e 31 22 29 port* "case2.1")
bb30: 0a 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 ... #t)...
bb40: 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 61 2d 77 ((and (null? a-w
bb50: 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 3b aitons) ;
bb60: 3b 20 6e 6f 20 77 61 69 74 6f 6e 73 20 66 6f 72 ; no waitons for
bb70: 20 61 20 62 75 74 20 62 20 68 61 73 20 77 61 69 a but b has wai
bb80: 74 6f 6e 73 0a 09 09 09 20 28 6e 6f 74 20 28 6e tons.... (not (n
bb90: 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 ull? b-waitons))
bba0: 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 )... ;; (debu
bbb0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
bbc0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 lt-log-port* "ca
bbd0: 73 65 33 22 29 0a 09 09 20 20 20 20 23 66 29 0a se3")... #f).
bbe0: 09 09 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 .. ((and (not
bbf0: 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 (null? a-waitons
bc00: 29 29 20 20 3b 3b 20 61 20 68 61 73 20 77 61 69 )) ;; a has wai
bc10: 74 6f 6e 73 20 62 75 74 20 62 20 64 6f 65 73 20 tons but b does
bc20: 6e 6f 74 0a 09 09 09 20 28 6e 75 6c 6c 3f 20 62 not.... (null? b
bc30: 2d 77 61 69 74 6f 6e 73 29 29 20 0a 09 09 20 20 -waitons)) ...
bc40: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
bc50: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
bc60: 2d 70 6f 72 74 2a 20 22 63 61 73 65 34 22 29 0a -port* "case4").
bc70: 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 .. #t)... (
bc80: 28 6e 6f 74 20 28 65 71 3f 20 61 2d 70 72 69 6f (not (eq? a-prio
bc90: 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 rity b-priority)
bca0: 29 20 3b 3b 20 75 73 65 0a 09 09 20 20 20 20 28 ) ;; use... (
bcb0: 3e 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 > a-priority b-p
bcc0: 72 69 6f 72 69 74 79 29 29 0a 09 09 20 20 20 28 riority))... (
bcd0: 65 6c 73 65 0a 09 09 20 20 20 20 3b 3b 20 28 64 else... ;; (d
bce0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
bcf0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
bd00: 22 63 61 73 65 35 22 29 0a 09 09 20 20 20 20 28 "case5")... (
bd10: 73 74 72 69 6e 67 3e 3f 20 61 20 62 29 29 29 29 string>? a b))))
bd20: 29 29 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 )).. ..
bd30: 28 73 6f 72 74 2d 66 6e 32 0a 09 20 20 20 20 20 (sort-fn2..
bd40: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
bd50: 09 28 3e 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 .(> (mungepriori
bd60: 74 79 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 ty (tests:testqu
bd70: 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 eue-get-priority
bd80: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
bd90: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 test-records a)
bda0: 29 29 0a 09 09 20 20 20 28 6d 75 6e 67 65 70 72 ))... (mungepr
bdb0: 69 6f 72 69 74 79 20 28 74 65 73 74 73 3a 74 65 iority (tests:te
bdc0: 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f stqueue-get-prio
bdd0: 72 69 74 79 20 28 68 61 73 68 2d 74 61 62 6c 65 rity (hash-table
bde0: 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
bdf0: 73 20 62 29 29 29 29 29 29 29 0a 09 3b 3b 20 28 s b)))))))..;; (
be00: 6c 65 74 20 28 28 64 6f 74 2d 72 65 73 20 28 74 let ((dot-res (t
be10: 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 74 65 ests:run-dot (te
be20: 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 sts:tests->dot t
be30: 65 73 74 2d 72 65 63 6f 72 64 73 29 20 22 70 6c est-records) "pl
be40: 61 69 6e 22 29 29 29 0a 09 3b 3b 20 20 20 28 64 ain")))..;; (d
be50: 65 62 75 67 3a 70 72 69 6e 74 20 22 64 6f 74 2d ebug:print "dot-
be60: 72 65 73 3d 22 20 64 6f 74 2d 72 65 73 29 29 0a res=" dot-res)).
be70: 09 3b 3b 20 28 6c 65 74 20 28 28 64 61 74 61 20 .;; (let ((data
be80: 28 6d 61 70 20 63 64 72 20 28 66 69 6c 74 65 72 (map cdr (filter
be90: 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 28 6c 61 ..;; .. (la
bea0: 6d 62 64 61 20 28 78 29 28 65 71 75 61 6c 3f 20 mbda (x)(equal?
beb0: 22 6e 6f 64 65 22 20 28 63 61 72 20 78 29 29 29 "node" (car x)))
bec0: 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 28 6d 61 ..;; .. (ma
bed0: 70 20 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 p string-split (
bee0: 74 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 tests:easy-dot t
bef0: 65 73 74 2d 72 65 63 6f 72 64 73 20 22 70 6c 61 est-records "pla
bf00: 69 6e 22 29 29 29 29 29 29 0a 09 3b 3b 20 20 20 in"))))))..;;
bf10: 28 6d 61 70 20 63 61 72 20 28 73 6f 72 74 20 64 (map car (sort d
bf20: 61 74 61 20 28 6c 61 6d 62 64 61 20 28 61 20 62 ata (lambda (a b
bf30: 29 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 20 20 )..;; ..
bf40: 28 3e 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (> (string->numb
bf50: 65 72 20 28 63 61 64 64 72 20 61 29 29 28 73 74 er (caddr a))(st
bf60: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
bf70: 64 64 72 20 62 29 29 29 29 29 29 29 0a 09 3b 3b ddr b)))))))..;;
bf80: 20 29 29 0a 09 28 73 6f 72 74 20 61 6c 6c 2d 74 ))..(sort all-t
bf90: 65 73 74 73 20 73 6f 72 74 2d 66 6e 31 29 29 29 ests sort-fn1)))
bfa0: 29 20 3b 3b 20 61 76 6f 69 64 20 64 65 61 6c 69 ) ;; avoid deali
bfb0: 6e 67 20 77 69 74 68 20 64 65 6c 65 74 65 64 20 ng with deleted
bfc0: 74 65 73 74 73 2c 20 6c 6f 6f 6b 20 61 74 20 74 tests, look at t
bfd0: 68 65 20 68 61 73 68 20 74 61 62 6c 65 0a 0a 28 he hash table..(
bfe0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 61 define (tests:ea
bff0: 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f sy-dot test-reco
c000: 72 64 73 20 6f 75 74 74 79 70 65 29 0a 20 20 28 rds outtype). (
c010: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 66 64 let-values (((fd
c020: 20 74 65 6d 70 2d 70 61 74 68 29 20 28 66 69 6c temp-path) (fil
c030: 65 2d 6d 6b 73 74 65 6d 70 20 28 63 6f 6e 63 20 e-mkstemp (conc
c040: 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 "/tmp/" (current
c050: 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2e 58 58 -user-name) ".XX
c060: 58 58 58 58 22 29 29 29 29 0a 20 20 20 20 28 6c XXXX")))). (l
c070: 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d et ((all-testnam
c080: 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b es (hash-table-k
c090: 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 eys test-records
c0a0: 29 29 0a 09 20 20 28 74 65 6d 70 2d 70 6f 72 74 )).. (temp-port
c0b0: 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 (open-outpu
c0c0: 74 2d 66 69 6c 65 2a 20 66 64 29 29 29 0a 20 20 t-file* fd))).
c0d0: 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 ;; (format t
c0e0: 65 6d 70 2d 70 6f 72 74 20 22 54 68 69 73 20 66 emp-port "This f
c0f0: 69 6c 65 20 69 73 20 7e 41 2e 7e 25 22 20 74 65 ile is ~A.~%" te
c100: 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 mp-path). (
c110: 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
c120: 20 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 "digraph tests
c130: 7b 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 {\n"). (for
c140: 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 mat temp-port "
c150: 20 73 69 7a 65 3d 34 2c 38 5c 6e 22 29 0a 20 20 size=4,8\n").
c160: 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 ;; (format t
c170: 65 6d 70 2d 70 6f 72 74 20 22 20 20 20 73 70 6c emp-port " spl
c180: 69 6e 65 73 3d 6e 6f 6e 65 5c 6e 22 29 0a 20 20 ines=none\n").
c190: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
c1a0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
c1b0: 73 74 6e 61 6d 65 29 0a 09 20 28 6c 65 74 2a 20 stname).. (let*
c1c0: 28 28 74 65 73 74 72 65 63 20 28 68 61 73 68 2d ((testrec (hash-
c1d0: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
c1e0: 65 63 6f 72 64 73 20 74 65 73 74 6e 61 6d 65 29 ecords testname)
c1f0: 29 0a 09 09 28 77 61 69 74 6f 6e 73 20 28 6f 72 )...(waitons (or
c200: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
c210: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 e-get-waitons te
c220: 73 74 72 65 63 29 20 27 28 29 29 29 29 0a 09 20 strec) '())))..
c230: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 (for-each..
c240: 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
c250: 29 0a 09 20 20 20 20 20 20 28 66 6f 72 6d 61 74 ).. (format
c260: 20 74 65 6d 70 2d 70 6f 72 74 20 28 63 6f 6e 63 temp-port (conc
c270: 20 22 20 20 20 22 20 77 61 69 74 6f 6e 20 22 20 " " waiton "
c280: 2d 3e 20 22 20 74 65 73 74 6e 61 6d 65 20 22 20 -> " testname "
c290: 5b 73 70 6c 69 6e 65 73 3d 6f 72 74 68 6f 5d 5c [splines=ortho]\
c2a0: 6e 22 29 29 29 0a 09 20 20 20 20 77 61 69 74 6f n"))).. waito
c2b0: 6e 73 29 29 29 0a 20 20 20 20 20 20 20 61 6c 6c ns))). all
c2c0: 2d 74 65 73 74 6e 61 6d 65 73 29 0a 20 20 20 20 -testnames).
c2d0: 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 (format temp-p
c2e0: 6f 72 74 20 22 7d 5c 6e 22 29 0a 20 20 20 20 20 ort "}\n").
c2f0: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
c300: 6f 72 74 20 74 65 6d 70 2d 70 6f 72 74 29 0a 20 ort temp-port).
c310: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
c320: 2d 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 20 -from-pipe.
c330: 20 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 (conc "env -i
c340: 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d PATH=$PATH dot -
c350: 54 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 T" outtype " < "
c360: 20 74 65 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 temp-path).
c370: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
c380: 28 6c 65 74 20 28 28 72 65 73 20 28 72 65 61 64 (let ((res (read
c390: 2d 6c 69 6e 65 73 29 29 29 0a 09 20 20 20 3b 3b -lines))).. ;;
c3a0: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 74 65 (delete-file te
c3b0: 6d 70 2d 70 61 74 68 29 0a 09 20 20 20 72 65 73 mp-path).. res
c3c0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
c3d0: 28 74 65 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 (tests:write-dot
c3e0: 2d 66 69 6c 65 20 74 65 73 74 2d 72 65 63 6f 72 -file test-recor
c3f0: 64 73 20 66 6e 61 6d 65 20 73 69 7a 65 78 20 73 ds fname sizex s
c400: 69 7a 65 79 29 0a 20 20 28 69 66 20 28 66 69 6c izey). (if (fil
c410: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
c420: 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 (pathname-direct
c430: 6f 72 79 20 66 6e 61 6d 65 29 29 0a 20 20 20 20 ory fname)).
c440: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
c450: 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 28 6c o-file fname..(l
c460: 61 6d 62 64 61 20 28 29 0a 09 20 20 28 6d 61 70 ambda ().. (map
c470: 20 70 72 69 6e 74 20 28 74 65 73 74 73 3a 74 65 print (tests:te
c480: 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 sts->dot test-re
c490: 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a 65 cords sizex size
c4a0: 79 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 y))))))..(define
c4b0: 20 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 (tests:tests->d
c4c0: 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ot test-records
c4d0: 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 sizex sizey). (
c4e0: 6c 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 let ((all-testna
c4f0: 6d 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d mes (hash-table-
c500: 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 keys test-record
c510: 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 s))). (if (nu
c520: 6c 6c 3f 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 ll? all-testname
c530: 73 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f s)..'()..(let lo
c540: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 61 6c op ((hed (car al
c550: 6c 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 l-testnames))...
c560: 20 20 20 28 74 61 6c 20 28 63 64 72 20 61 6c 6c (tal (cdr all
c570: 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 -testnames))...
c580: 20 20 28 72 65 73 20 28 6c 69 73 74 20 22 64 69 (res (list "di
c590: 67 72 61 70 68 20 74 65 73 74 73 20 7b 22 0a 09 graph tests {"..
c5a0: 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 22 20 .. (conc "
c5b0: 73 69 7a 65 3d 5c 22 22 20 28 6f 72 20 73 69 7a size=\"" (or siz
c5c0: 65 78 20 31 31 29 20 22 2c 22 20 28 6f 72 20 73 ex 11) "," (or s
c5d0: 69 7a 65 79 20 31 31 29 20 22 5c 22 3b 22 29 0a izey 11) "\";").
c5e0: 09 09 09 20 20 20 20 20 20 22 20 72 61 74 69 6f ... " ratio
c5f0: 3d 30 2e 39 35 3b 22 0a 09 09 09 20 20 20 20 20 =0.95;"....
c600: 20 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 ))).. (let* ((
c610: 74 65 73 74 72 65 63 20 28 68 61 73 68 2d 74 61 testrec (hash-ta
c620: 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
c630: 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 77 ords hed))... (w
c640: 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 aitons (or (test
c650: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
c660: 77 61 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 waitons testrec)
c670: 20 27 28 29 29 29 0a 09 09 20 28 6e 65 77 72 65 '()))... (newre
c680: 73 20 20 28 61 70 70 65 6e 64 20 72 65 73 0a 09 s (append res..
c690: 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ... (if (null?
c6a0: 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 waitons).....
c6b0: 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 (list (conc "
c6c0: 20 20 20 5c 22 22 20 68 65 64 20 22 5c 22 20 5b \"" hed "\" [
c6d0: 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 shape=box];"))..
c6e0: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
c6f0: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
c700: 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 .... (conc "
c710: 20 20 20 5c 22 22 20 77 61 69 74 6f 6e 20 22 5c \"" waiton "\
c720: 22 20 2d 3e 20 5c 22 22 20 68 65 64 20 22 5c 22 " -> \"" hed "\"
c730: 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 [shape=box];"))
c740: 0a 09 09 09 09 09 20 20 20 77 61 69 74 6f 6e 73 ...... waitons
c750: 29 0a 09 09 09 09 20 20 20 20 20 20 29 29 29 29 )..... ))))
c760: 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f .. (if (null?
c770: 20 74 61 6c 29 0a 09 09 28 61 70 70 65 6e 64 20 tal)...(append
c780: 6e 65 77 72 65 73 20 28 6c 69 73 74 20 22 7d 22 newres (list "}"
c790: 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 ))...(loop (car
c7a0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 tal)(cdr tal) ne
c7b0: 77 72 65 73 29 0a 09 09 29 29 29 29 29 29 0a 0a wres)...))))))..
c7c0: 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f ;; (tests:run-do
c7d0: 74 20 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 t (list "digraph
c7e0: 20 74 65 73 74 73 20 7b 22 20 22 61 20 2d 3e 20 tests {" "a ->
c7f0: 62 22 20 22 7d 22 29 20 22 70 6c 61 69 6e 22 29 b" "}") "plain")
c800: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
c810: 3a 72 75 6e 2d 64 6f 74 20 69 6e 64 61 74 20 6f :run-dot indat o
c820: 75 74 74 79 70 65 29 20 3b 3b 20 6f 75 74 74 79 uttype) ;; outty
c830: 70 65 20 69 73 20 70 6c 61 69 6e 2c 20 66 69 67 pe is plain, fig
c840: 2c 20 64 6f 74 2c 20 65 74 63 2e 20 68 74 74 70 , dot, etc. http
c850: 3a 2f 2f 77 77 77 2e 67 72 61 70 68 76 69 7a 2e ://www.graphviz.
c860: 6f 72 67 2f 63 6f 6e 74 65 6e 74 2f 6f 75 74 70 org/content/outp
c870: 75 74 2d 66 6f 72 6d 61 74 73 0a 20 20 28 6c 65 ut-formats. (le
c880: 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 t-values (((inp
c890: 6f 75 70 20 70 69 64 29 28 70 72 6f 63 65 73 73 oup pid)(process
c8a0: 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 "env -i PATH=$P
c8b0: 41 54 48 20 64 6f 74 22 20 28 6c 69 73 74 20 22 ATH dot" (list "
c8c0: 2d 54 22 20 6f 75 74 74 79 70 65 29 29 29 29 0a -T" outtype)))).
c8d0: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
c8e0: 2d 74 6f 2d 70 6f 72 74 20 6f 75 70 0a 20 20 20 -to-port oup.
c8f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
c900: 6d 61 70 20 70 72 69 6e 74 20 69 6e 64 61 74 29 map print indat)
c910: 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 )). (close-ou
c920: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 tput-port oup).
c930: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 77 (let ((res (w
c940: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
c950: 6f 72 74 20 69 6e 70 0a 09 09 20 28 6c 61 6d 62 ort inp... (lamb
c960: 64 61 20 28 29 0a 09 09 20 20 20 28 72 65 61 64 da ()... (read
c970: 2d 6c 69 6e 65 73 29 29 29 29 29 0a 20 20 20 20 -lines))))).
c980: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
c990: 6f 72 74 20 69 6e 70 29 0a 20 20 20 20 20 20 72 ort inp). r
c9a0: 65 73 29 29 29 0a 0a 3b 3b 20 72 65 61 64 20 64 es)))..;; read d
c9b0: 61 74 61 20 66 72 6f 6d 20 74 6d 70 20 66 69 6c ata from tmp fil
c9c0: 65 20 6f 72 20 63 72 65 61 74 65 20 69 66 20 6e e or create if n
c9d0: 6f 74 20 65 78 69 73 74 73 0a 3b 3b 20 69 66 20 ot exists.;; if
c9e0: 65 78 69 73 74 73 20 72 65 67 65 6e 20 69 6e 20 exists regen in
c9f0: 62 61 63 6b 67 72 6f 75 6e 64 0a 3b 3b 0a 28 64 background.;;.(d
ca00: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c 61 7a efine (tests:laz
ca10: 79 2d 64 6f 74 20 74 65 73 74 72 65 63 6f 72 64 y-dot testrecord
ca20: 73 20 20 6f 75 74 74 79 70 65 20 73 69 7a 65 78 s outtype sizex
ca30: 20 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 sizey). (let (
ca40: 28 64 66 69 6c 65 20 28 63 6f 6e 63 20 22 2f 74 (dfile (conc "/t
ca50: 6d 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 mp/." (current-u
ca60: 73 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 ser-name) "-" (s
ca70: 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 erver:mk-signatu
ca80: 72 65 29 20 22 2e 64 6f 74 22 29 29 0a 09 28 66 re) ".dot"))..(f
ca90: 6e 61 6d 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 name (conc "/tmp
caa0: 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 /." (current-use
cab0: 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 65 72 r-name) "-" (ser
cac0: 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 ver:mk-signature
cad0: 29 20 22 2e 64 6f 74 64 61 74 22 29 29 29 0a 20 ) ".dotdat"))).
cae0: 20 20 20 28 74 65 73 74 73 3a 77 72 69 74 65 2d (tests:write-
caf0: 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 72 65 63 dot-file testrec
cb00: 6f 72 64 73 20 64 66 69 6c 65 20 73 69 7a 65 78 ords dfile sizex
cb10: 20 73 69 7a 65 79 29 0a 20 20 20 20 28 69 66 20 sizey). (if
cb20: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e (file-exists? fn
cb30: 61 6d 65 29 0a 09 28 6c 65 74 20 28 28 72 65 73 ame)..(let ((res
cb40: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
cb50: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 20 m-file fname...
cb60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
cb70: 09 20 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 . (read-li
cb80: 6e 65 73 29 29 29 29 29 0a 09 20 20 28 73 79 73 nes))))).. (sys
cb90: 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d tem (conc "env -
cba0: 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 i PATH=$PATH dot
cbb0: 20 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 20 -T " outtype "
cbc0: 3c 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 20 < " dfile " > "
cbd0: 66 6e 61 6d 65 20 22 26 22 29 29 0a 09 20 20 72 fname "&")).. r
cbe0: 65 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 es)..(begin.. (
cbf0: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e system (conc "en
cc00: 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 v -i PATH=$PATH
cc10: 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 dot -T " outtype
cc20: 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e " < " dfile " >
cc30: 20 22 20 66 6e 61 6d 65 29 29 0a 09 20 20 28 77 " fname)).. (w
cc40: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
cc50: 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 ile fname.. (
cc60: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
cc70: 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 (read-lines))))
cc80: 29 29 29 0a 09 20 20 0a 0a 3b 3b 20 66 6f 72 20 ))).. ..;; for
cc90: 65 61 63 68 20 74 65 73 74 3a 0a 3b 3b 20 20 20 each test:.;;
cca0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
ccb0: 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 filter-non-runna
ccc0: 62 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6b ble run-id testk
ccd0: 65 79 6e 61 6d 65 73 20 74 65 73 74 72 65 63 6f eynames testreco
cce0: 72 64 73 68 61 73 68 29 0a 20 20 28 6c 65 74 20 rdshash). (let
ccf0: 28 28 72 75 6e 6e 61 62 6c 65 73 20 27 28 29 29 ((runnables '())
cd00: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
cd10: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
cd20: 73 74 6b 65 79 6e 61 6d 65 29 0a 20 20 20 20 20 stkeyname).
cd30: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 (let* ((test-r
cd40: 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c ecord (hash-tabl
cd50: 65 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 e-ref testrecord
cd60: 73 68 61 73 68 20 74 65 73 74 6b 65 79 6e 61 6d shash testkeynam
cd70: 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
cd80: 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 -name (tests:t
cd90: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
cda0: 74 6e 61 6d 65 20 20 74 65 73 74 2d 72 65 63 6f tname test-reco
cdb0: 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 rd)).. (ite
cdc0: 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 3a mdat (tests:
cdd0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
cde0: 65 6d 64 61 74 20 20 20 74 65 73 74 2d 72 65 63 emdat test-rec
cdf0: 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 ord)).. (it
ce00: 65 6d 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 em-path (tests
ce10: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
ce20: 74 65 6d 5f 70 61 74 68 20 74 65 73 74 2d 72 65 tem_path test-re
ce30: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 77 cord)).. (w
ce40: 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 aitons (test
ce50: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
ce60: 77 61 69 74 6f 6e 73 20 20 20 74 65 73 74 2d 72 waitons test-r
ce70: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 ecord)).. (
ce80: 6b 65 65 70 2d 74 65 73 74 20 20 20 23 74 29 0a keep-test #t).
ce90: 09 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 . (test-id
cea0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
ceb0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
cec0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
ced0: 29 0a 09 20 20 20 20 20 20 28 74 64 61 74 20 20 ).. (tdat
cee0: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 (rmt:get-t
cef0: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
cf00: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
cf10: 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 -id))) ;; (cdb:g
cf20: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
cf30: 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 id *runremote* t
cf40: 65 73 74 2d 69 64 29 29 29 0a 09 20 28 69 66 20 est-id))).. (if
cf50: 74 64 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 tdat.. (begi
cf60: 6e 0a 09 20 20 20 20 20 20 20 3b 3b 20 4c 6f 6f n.. ;; Loo
cf70: 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 73 74 k at the test st
cf80: 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 0a 09 ate and status..
cf90: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
cfa0: 61 6e 64 20 28 6d 65 6d 62 65 72 20 28 64 62 3a and (member (db:
cfb0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
cfc0: 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 20 27 tdat) ..... '
cfd0: 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
cfe0: 57 41 49 56 45 44 22 20 22 43 48 45 43 4b 22 20 WAIVED" "CHECK"
cff0: 22 53 4b 49 50 22 29 29 0a 09 09 09 20 20 20 20 "SKIP"))....
d000: 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 (equal? (db:test
d010: 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 -get-state tdat)
d020: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 09 "COMPLETED"))..
d030: 09 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 . (member
d040: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
d050: 74 65 20 74 64 61 74 29 0a 09 09 09 09 20 20 20 te tdat).....
d060: 20 27 28 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 '("INCOMPLETE"
d070: 22 4b 49 4c 4c 45 44 22 29 29 29 0a 09 09 20 20 "KILLED")))...
d080: 20 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 (set! keep-test
d090: 20 23 66 29 29 0a 0a 09 20 20 20 20 20 20 20 3b #f))... ;
d0a0: 3b 20 65 78 61 6d 69 6e 65 20 77 61 69 74 6f 6e ; examine waiton
d0b0: 73 20 66 6f 72 20 61 6e 79 20 66 61 69 6c 73 2e s for any fails.
d0c0: 20 49 66 20 69 74 20 69 73 20 46 41 49 4c 20 6f If it is FAIL o
d0d0: 72 20 49 4e 43 4f 4d 50 4c 45 54 45 20 74 68 65 r INCOMPLETE the
d0e0: 6e 20 65 6c 69 6d 69 6e 61 74 65 20 74 68 69 73 n eliminate this
d0f0: 20 74 65 73 74 0a 09 20 20 20 20 20 20 20 3b 3b test.. ;;
d100: 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 6e 61 62 from the runnab
d110: 6c 65 20 6c 69 73 74 0a 09 20 20 20 20 20 20 20 le list..
d120: 28 69 66 20 6b 65 65 70 2d 74 65 73 74 0a 09 09 (if keep-test...
d130: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
d140: 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 mbda (waiton)...
d150: 09 20 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 6e . ;; for n
d160: 6f 77 20 77 65 20 61 72 65 20 77 61 69 74 69 6e ow we are waitin
d170: 67 20 6f 6e 6c 79 20 6f 6e 20 74 68 65 20 70 61 g only on the pa
d180: 72 65 6e 74 20 74 65 73 74 0a 09 09 09 20 20 20 rent test....
d190: 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 72 65 (let* ((pare
d1a0: 6e 74 2d 74 65 73 74 2d 69 64 20 28 72 6d 74 3a nt-test-id (rmt:
d1b0: 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
d1c0: 69 64 20 77 61 69 74 6f 6e 20 22 22 29 29 0a 09 id waiton ""))..
d1d0: 09 09 09 20 20 20 20 20 20 28 77 74 64 61 74 20 ... (wtdat
d1e0: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
d1f0: 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 t-testinfo-state
d200: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 -status run-id t
d210: 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 est-id))) ;; (cd
d220: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d b:get-test-info-
d230: 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 by-id *runremote
d240: 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 * test-id)))....
d250: 09 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 . (if (or (and (
d260: 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
d270: 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 get-state wtdat)
d280: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
d290: 09 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
d2a0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
d2b0: 61 74 75 73 20 77 74 64 61 74 29 20 27 28 22 46 atus wtdat) '("F
d2c0: 41 49 4c 22 20 22 41 42 4f 52 54 22 29 29 29 0a AIL" "ABORT"))).
d2d0: 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 ..... (member (d
d2e0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
d2f0: 73 20 77 74 64 61 74 29 20 20 27 28 22 4b 49 4c s wtdat) '("KIL
d300: 4c 45 44 22 29 29 0a 09 09 09 09 09 20 28 6d 65 LED"))...... (me
d310: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
d320: 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 20 20 t-state wtdat)
d330: 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 '("INCOMPETE"))
d340: 29 0a 09 09 09 09 20 3b 3b 20 28 69 66 20 28 6f )..... ;; (if (o
d350: 72 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 r (member (db:te
d360: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 st-get-status wt
d370: 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 dat)..... ;;
d380: 20 20 20 20 09 20 27 28 22 46 41 49 4c 22 20 22 . '("FAIL" "
d390: 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 09 20 3b KILLED"))..... ;
d3a0: 3b 20 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 ; (membe
d3b0: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
d3c0: 74 61 74 65 20 77 74 64 61 74 29 0a 09 09 09 09 tate wtdat).....
d3d0: 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 ;; . '("
d3e0: 49 4e 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 INCOMPETE")))...
d3f0: 09 09 20 20 20 20 20 28 73 65 74 21 20 6b 65 65 .. (set! kee
d400: 70 2d 74 65 73 74 20 23 66 29 29 29 29 20 3b 3b p-test #f)))) ;;
d410: 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 6e no point in run
d420: 6e 69 6e 67 20 74 68 69 73 20 6f 6e 65 20 61 67 ning this one ag
d430: 61 69 6e 0a 09 09 09 20 20 20 20 20 77 61 69 74 ain.... wait
d440: 6f 6e 73 29 29 29 29 0a 09 20 28 69 66 20 6b 65 ons)))).. (if ke
d450: 65 70 2d 74 65 73 74 20 28 73 65 74 21 20 72 75 ep-test (set! ru
d460: 6e 6e 61 62 6c 65 73 20 28 63 6f 6e 73 20 74 65 nnables (cons te
d470: 73 74 6b 65 79 6e 61 6d 65 20 72 75 6e 6e 61 62 stkeyname runnab
d480: 6c 65 73 29 29 29 29 29 0a 20 20 20 20 20 74 65 les))))). te
d490: 73 74 6b 65 79 6e 61 6d 65 73 29 0a 20 20 20 20 stkeynames).
d4a0: 72 75 6e 6e 61 62 6c 65 73 29 29 0a 0a 3b 3b 3d runnables))..;;=
d4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4f0: 3d 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 61 63 74 6f =====.;; refacto
d500: 72 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 ring this block
d510: 69 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 into tests:get-f
d520: 75 6c 6c 2d 64 61 74 61 20 66 72 6f 6d 20 6c 69 ull-data from li
d530: 6e 65 20 32 36 33 20 6f 66 20 72 75 6e 73 2e 73 ne 263 of runs.s
d540: 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d cm.;;===========
d550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 ===========.;; h
d590: 65 64 20 69 73 20 74 68 65 20 74 65 73 74 20 6e ed is the test n
d5a0: 61 6d 65 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f ame.;; test-reco
d5b0: 72 64 73 20 69 73 20 61 20 68 61 73 68 20 6f 66 rds is a hash of
d5c0: 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 test-name => te
d5d0: 73 74 20 72 65 63 6f 72 64 0a 28 64 65 66 69 6e st record.(defin
d5e0: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 66 75 6c e (tests:get-ful
d5f0: 6c 2d 64 61 74 61 20 74 65 73 74 2d 6e 61 6d 65 l-data test-name
d600: 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 s test-records r
d610: 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 61 6c equired-tests al
d620: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
d630: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 ). (if (not (nu
d640: 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ll? test-names))
d650: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
d660: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
d670: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 28 74 61 6c -names))... (tal
d680: 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 (cdr test-names
d690: 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 ))) ;; '
d6a0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c return-procs tel
d6b0: 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 ls the config re
d6c0: 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e ader to prep run
d6d0: 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 ning system but
d6e0: 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 28 return a proc..(
d6f0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
d700: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
d710: 70 6f 72 74 2a 20 22 68 65 64 3d 22 20 68 65 64 port* "hed=" hed
d720: 20 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f " at top of loo
d730: 70 22 29 0a 09 28 6c 65 74 2a 20 28 28 63 6f 6e p")..(let* ((con
d740: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
d750: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 61 testconfig hed a
d760: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
d770: 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 y 'return-procs)
d780: 29 0a 09 20 20 20 20 20 20 20 28 77 61 69 74 6f ).. (waito
d790: 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 ns (let ((instr
d7a0: 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 (if config .....
d7b0: 09 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 . (config-lookup
d7c0: 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
d7d0: 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 ments" "waiton")
d7e0: 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b 3b ...... (begin ;;
d7f0: 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 No config means
d800: 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 this is a non-e
d810: 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 xistant test....
d820: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
d830: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
d840: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f lt-log-port* "no
d850: 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 n-existent requi
d860: 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 red test \"" hed
d870: 20 22 5c 22 2c 20 67 72 65 70 20 74 68 72 6f 75 "\", grep throu
d880: 67 68 20 79 6f 75 72 20 74 65 73 74 63 6f 6e 66 gh your testconf
d890: 69 67 73 20 74 6f 20 66 69 6e 64 20 61 6e 64 20 igs to find and
d8a0: 72 65 6d 6f 76 65 20 6f 72 20 63 72 65 61 74 65 remove or create
d8b0: 20 74 68 65 20 74 65 73 74 2e 20 44 69 73 63 61 the test. Disca
d8c0: 72 64 69 6e 67 20 61 6e 64 20 63 6f 6e 74 69 6e rding and contin
d8d0: 75 69 6e 67 2e 22 29 0a 09 09 09 09 09 20 20 20 uing.")......
d8e0: 20 20 22 22 29 29 29 29 0a 09 09 09 20 20 28 64 "")))).... (d
d8f0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
d900: 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
d910: 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 73 74 ort* "waitons st
d920: 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 ring is " instr)
d930: 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d 73 70 .... (string-sp
d940: 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 20 lit (cond......
d950: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 ((procedure? ins
d960: 74 72 29 0a 09 09 09 09 09 20 20 28 6c 65 74 20 tr)...... (let
d970: 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 0a ((res (instr))).
d980: 09 09 09 09 09 20 20 20 20 28 64 65 62 75 67 3a ..... (debug:
d990: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
d9a0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
d9b0: 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 "waiton procedur
d9c0: 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 e results in str
d9d0: 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 ing " res " for
d9e0: 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 test " hed).....
d9f0: 09 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 . res))......
da00: 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 ((string? instr
da10: 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 ) instr)....
da20: 09 09 20 28 65 6c 73 65 20 0a 09 09 09 09 09 20 .. (else ......
da30: 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 ;; NOTE: This i
da40: 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 s actually the c
da50: 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 ase of *no* wait
da60: 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 ons! ;; (debug:p
da70: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
da80: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
da90: 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 "something went
daa0: 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 wrong in process
dab0: 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 ing waitons for
dac0: 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 test " hed).....
dad0: 09 20 20 22 22 29 29 29 29 29 29 0a 09 20 20 28 . "")))))).. (
dae0: 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 67 29 20 if (not config)
daf0: 3b 3b 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e ;; this is a non
db00: 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 20 63 -existant test c
db10: 61 6c 6c 65 64 20 69 6e 20 61 20 77 61 69 74 6f alled in a waito
db20: 6e 2e 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 n. .. (if (
db30: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 74 null? tal)... t
db40: 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 20 20 est-records...
db50: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
db60: 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 20 cdr tal)))..
db70: 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 (begin...(debu
db80: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a g:print-info 8 *
db90: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
dba0: 2a 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 * "waitons: " wa
dbb0: 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 68 65 63 itons)...;; chec
dbc0: 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 k for hed in wai
dbd0: 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 tons => this wou
dbe0: 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 ld be circular,
dbf0: 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 remove it and is
dc00: 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 72 72 6f sue an...;; erro
dc10: 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 65 72 20 r...(if (member
dc20: 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 20 hed waitons)...
dc30: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
dc40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
dc50: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
dc60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 log-port* "test
dc70: 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 " hed " has list
dc80: 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 ed itself as a w
dc90: 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f aiton, please co
dca0: 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 rrect this!")...
dcb0: 20 20 20 20 20 20 28 73 65 74 21 20 77 61 69 74 (set! wait
dcc0: 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ons (filter (lam
dcd0: 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 bda (x)(not (equ
dce0: 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 al? x hed))) wai
dcf0: 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 09 3b 3b tons))))......;;
dd00: 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d 73 (items (items
dd10: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
dd20: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 29 config config)))
dd30: 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 68 61 73 ...(if (not (has
dd40: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
dd50: 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ult test-records
dd60: 20 68 65 64 20 23 66 29 29 0a 09 09 20 20 20 20 hed #f))...
dd70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
dd80: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 test-records...
dd90: 09 09 20 20 20 20 20 68 65 64 20 28 76 65 63 74 .. hed (vect
dda0: 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 0a or hed ;; 0.
ddb0: 09 09 09 09 09 09 20 63 6f 6e 66 69 67 20 20 3b ...... config ;
ddc0: 3b 20 31 0a 09 09 09 09 09 09 20 77 61 69 74 6f ; 1....... waito
ddd0: 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 09 20 28 ns ;; 2....... (
dde0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f config-lookup co
ddf0: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
de00: 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 20 ts" "priority")
de10: 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 ;; priority
de20: 33 0a 09 09 09 09 09 09 20 28 6c 65 74 20 28 28 3....... (let ((
de30: 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 items (hash
de40: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
de50: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
de60: 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 " #f)) ;; items
de70: 34 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 4....... (
de80: 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 itemstable (hash
de90: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
dea0: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
deb0: 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 table" #f))) ...
dec0: 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 69 74 .... ;; if eit
ded0: 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 her items or ite
dee0: 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 ms table is a pr
def0: 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 oc return it so
df00: 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 test running....
df10: 09 09 09 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 ... ;; process
df20: 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c can know to cal
df30: 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d l items:get-item
df40: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 s-from-config...
df50: 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 69 74 .... ;; if eit
df60: 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e her is a list an
df70: 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 d none is a proc
df80: 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 go ahead and ca
df90: 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 ll get-items....
dfa0: 09 09 09 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 ... ;; otherwi
dfb0: 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 se return #f - t
dfc0: 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 his is not an it
dfd0: 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 erated test.....
dfe0: 09 09 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 .. (cond......
dff0: 09 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 . ((procedure
e000: 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 ? items) ..
e010: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
e020: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
e030: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e040: 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f "items is a pro
e050: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
e060: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
e070: 20 20 20 20 20 69 74 65 6d 73 29 20 20 20 20 20 items)
e080: 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
e090: 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 ater....... (
e0a0: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
e0b0: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 20 stable).......
e0c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
e0d0: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
e0e0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 log-port* "items
e0f0: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 table is a proce
e100: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
e110: 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 20 later").......
e120: 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 itemstable)
e130: 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 ;; calc lat
e140: 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 28 66 er....... ((f
e150: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
e160: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 20 )........
e170: 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 (let ((val (car
e180: 78 29 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 x)))......... (i
e190: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
e1a0: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 l) val #f)))....
e1b0: 09 09 09 09 20 20 20 20 20 28 61 70 70 65 6e 64 .... (append
e1c0: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
e1d0: 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 s) items '())...
e1e0: 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 28 ...... (if (
e1f0: 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 list? itemstable
e200: 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 ) itemstable '()
e210: 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 27 )))....... '
e220: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a have-procedure).
e230: 09 09 09 09 09 09 20 20 20 20 28 28 6f 72 20 28 ...... ((or (
e240: 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 list? items)(lis
e250: 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 t? itemstable))
e260: 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 ;; calc now.....
e270: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
e280: 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
e290: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 ult-log-port* "i
e2a0: 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 61 tems and itemsta
e2b0: 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c 20 63 ble are lists, c
e2c0: 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 alc now\n"......
e2d0: 09 09 09 20 20 20 20 20 20 20 22 20 20 20 20 69 ... " i
e2e0: 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 tems: " items "
e2f0: 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 itemstable: " it
e300: 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 emstable).......
e310: 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d (items:get-
e320: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
e330: 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 g config))......
e340: 09 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 . (else #f)))
e350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e360: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f ;; no
e370: 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 t iterated......
e380: 09 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 . #f ;; ite
e390: 6d 73 64 61 74 20 35 0a 09 09 09 09 09 09 20 23 msdat 5....... #
e3a0: 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 f ;; spare
e3b0: 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d - used for item-
e3c0: 70 61 74 68 0a 09 09 09 09 09 09 20 29 29 29 0a path....... ))).
e3d0: 09 09 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 20 ..(for-each ...
e3e0: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
e3f0: 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 77 ... (if (and w
e400: 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 aiton (not (memb
e410: 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e er waiton test-n
e420: 61 6d 65 73 29 29 29 0a 09 09 20 20 20 20 20 20 ames)))...
e430: 20 28 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 (begin.... (set
e440: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
e450: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 (cons waiton re
e460: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
e470: 09 09 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 .. (set! test-na
e480: 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e mes (cons waiton
e490: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 test-names)))))
e4a0: 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e ;; was an appen
e4b0: 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 09 d, now a cons...
e4c0: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 6c 65 74 waitons)...(let
e4d0: 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c ((remtests (del
e4e0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
e4f0: 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 append waitons t
e500: 61 6c 29 29 29 29 0a 09 09 20 20 28 69 66 20 28 al))))... (if (
e510: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 not (null? remte
e520: 73 74 73 29 29 0a 09 09 20 20 20 20 20 20 28 6c sts))... (l
e530: 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 oop (car remtest
e540: 73 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 s)(cdr remtests)
e550: 29 0a 09 09 20 20 20 20 20 20 74 65 73 74 2d 72 )... test-r
e560: 65 63 6f 72 64 73 29 29 29 29 29 29 29 29 0a 0a ecords))))))))..
e570: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
e580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5b0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 73 74 ========.;; test
e5c0: 20 73 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d steps.;;=======
e5d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
e610: 0a 3b 3b 20 74 65 73 74 73 74 65 70 2d 73 65 74 .;; teststep-set
e620: 2d 73 74 61 74 75 73 21 20 75 73 65 64 20 74 6f -status! used to
e630: 20 62 65 20 68 65 72 65 0a 0a 28 64 65 66 69 6e be here..(defin
e640: 65 20 28 74 65 73 74 2d 67 65 74 2d 6b 69 6c 6c e (test-get-kill
e650: 2d 72 65 71 75 65 73 74 20 72 75 6e 2d 69 64 20 -request run-id
e660: 74 65 73 74 2d 69 64 29 20 3b 3b 20 72 75 6e 2d test-id) ;; run-
e670: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
e680: 6d 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 mdat). (let* ((
e690: 74 65 73 74 64 61 74 20 20 20 28 72 6d 74 3a 67 testdat (rmt:g
e6a0: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
e6b0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
e6c0: 64 29 29 29 0a 20 20 20 20 28 61 6e 64 20 74 65 d))). (and te
e6d0: 73 74 64 61 74 0a 09 20 28 65 71 75 61 6c 3f 20 stdat.. (equal?
e6e0: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
e6f0: 74 65 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 45 testdat) "KILLRE
e700: 51 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 Q"))))..(define
e710: 28 74 65 73 74 3a 74 64 62 2d 67 65 74 2d 72 75 (test:tdb-get-ru
e720: 6e 64 61 74 2d 63 6f 75 6e 74 20 74 64 62 29 0a ndat-count tdb).
e730: 20 20 28 69 66 20 74 64 62 0a 20 20 20 20 20 20 (if tdb.
e740: 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a 09 (let ((res 0))..
e750: 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
e760: 77 0a 09 20 28 6c 61 6d 62 64 61 20 28 63 6f 75 w.. (lambda (cou
e770: 6e 74 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 nt).. (set! re
e780: 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6f s (vector-ref co
e790: 75 6e 74 20 30 29 29 29 0a 09 20 74 64 62 0a 09 unt 0))).. tdb..
e7a0: 20 22 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 69 "SELECT count(i
e7b0: 64 29 20 46 52 4f 4d 20 74 65 73 74 5f 72 75 6e d) FROM test_run
e7c0: 64 61 74 3b 22 29 0a 09 72 65 73 29 29 0a 20 20 dat;")..res)).
e7d0: 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 0)..(define (tes
e7e0: 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 ts:update-centra
e7f0: 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d l-meta-info run-
e800: 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f id test-id cpulo
e810: 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 ad diskfree minu
e820: 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 tes uname hostna
e830: 6d 65 29 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 me). (rmt:gener
e840: 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
e850: 74 65 73 74 2d 72 75 6e 64 61 74 20 72 75 6e 2d test-rundat run-
e860: 69 64 20 74 65 73 74 2d 69 64 20 28 63 75 72 72 id test-id (curr
e870: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 6f 72 ent-seconds) (or
e880: 20 63 70 75 6c 6f 61 64 20 2d 31 29 28 6f 72 20 cpuload -1)(or
e890: 64 69 73 6b 66 72 65 65 20 2d 31 29 20 2d 31 20 diskfree -1) -1
e8a0: 28 6f 72 20 6d 69 6e 75 74 65 73 20 2d 31 29 29 (or minutes -1))
e8b0: 0a 20 20 28 69 66 20 28 61 6e 64 20 63 70 75 6c . (if (and cpul
e8c0: 6f 61 64 20 64 69 73 6b 66 72 65 65 29 0a 20 20 oad diskfree).
e8d0: 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c (rmt:general
e8e0: 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 63 70 -call 'update-cp
e8f0: 75 6c 6f 61 64 2d 64 69 73 6b 66 72 65 65 20 72 uload-diskfree r
e900: 75 6e 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 un-id cpuload di
e910: 73 6b 66 72 65 65 20 74 65 73 74 2d 69 64 29 29 skfree test-id))
e920: 0a 20 20 28 69 66 20 6d 69 6e 75 74 65 73 20 0a . (if minutes .
e930: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 (rmt:gener
e940: 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
e950: 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 72 75 6e run-duration run
e960: 2d 69 64 20 6d 69 6e 75 74 65 73 20 74 65 73 74 -id minutes test
e970: 2d 69 64 29 29 0a 20 20 28 69 66 20 28 61 6e 64 -id)). (if (and
e980: 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 uname hostname)
e990: 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 . (rmt:gene
e9a0: 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 ral-call 'update
e9b0: 2d 75 6e 61 6d 65 2d 68 6f 73 74 20 72 75 6e 2d -uname-host run-
e9c0: 69 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d id uname hostnam
e9d0: 65 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 0a e test-id))). .
e9e0: 3b 3b 20 54 68 69 73 20 6f 6e 65 20 69 73 20 66 ;; This one is f
e9f0: 6f 72 20 72 75 6e 6e 69 6e 67 20 77 69 74 68 20 or running with
ea00: 6e 6f 20 64 62 20 61 63 63 65 73 73 20 28 69 2e no db access (i.
ea10: 65 2e 20 76 69 61 20 72 6d 74 3a 20 69 6e 74 65 e. via rmt: inte
ea20: 72 6e 61 6c 6c 79 29 0a 28 64 65 66 69 6e 65 20 rnally).(define
ea30: 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d (tests:set-full-
ea40: 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 meta-info db tes
ea50: 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
ea60: 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 65 tes work-area re
ea70: 6d 74 72 69 65 73 29 0a 3b 3b 20 28 64 65 66 69 mtries).;; (defi
ea80: 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 ne (tests:set-fu
ea90: 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 ll-meta-info tes
eaa0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
eab0: 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 3b tes work-area).;
eac0: 3b 20 20 28 6c 65 74 20 28 28 72 65 6d 74 72 69 ; (let ((remtri
ead0: 65 73 20 31 30 29 29 0a 20 20 28 6c 65 74 2a 20 es 10)). (let*
eae0: 28 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d ((cpuload (get-
eaf0: 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 69 cpu-load)).. (di
eb00: 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 skfree (get-df (
eb10: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
eb20: 79 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 20 20 y))).. (uname
eb30: 20 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 72 (get-uname "-sr
eb40: 76 70 69 6f 22 29 29 0a 09 20 28 68 6f 73 74 6e vpio")).. (hostn
eb50: 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ame (get-host-na
eb60: 6d 65 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 me))). (tests
eb70: 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d :update-central-
eb80: 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 meta-info run-id
eb90: 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 test-id cpuload
eba0: 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 diskfree minute
ebb0: 73 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 s uname hostname
ebc0: 29 29 29 0a 20 20 20 20 0a 3b 3b 20 28 64 65 66 ))). .;; (def
ebd0: 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 70 ine (tests:set-p
ebe0: 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f artial-meta-info
ebf0: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
ec00: 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
ec10: 61 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 a).(define (test
ec20: 73 3a 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 s:set-partial-me
ec30: 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 ta-info test-id
ec40: 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
ec50: 6f 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 ork-area remtrie
ec60: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 s). (let* ((cpu
ec70: 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c load (get-cpu-l
ec80: 6f 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 oad)).. (diskfre
ec90: 65 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 e (get-df (curre
eca0: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a nt-directory))).
ecb0: 09 20 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 . (remtries 10))
ecc0: 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
ecd0: 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e eptions. exn
ece0: 0a 20 20 20 20 20 28 69 66 20 28 3e 20 72 65 6d . (if (> rem
ecf0: 74 72 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 tries 0).. (begi
ed00: 6e 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c n.. (print-cal
ed10: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
ed20: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 -error-port))..
ed30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
ed40: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
ed50: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
ed60: 47 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 65 74 G: failed to set
ed70: 20 6d 65 74 61 20 69 6e 66 6f 2e 20 57 69 6c 6c meta info. Will
ed80: 20 74 72 79 20 22 20 72 65 6d 74 72 69 65 73 20 try " remtries
ed90: 22 20 6d 6f 72 65 20 74 69 6d 65 73 22 29 0a 09 " more times")..
eda0: 20 20 20 28 73 65 74 21 20 72 65 6d 74 72 69 65 (set! remtrie
edb0: 73 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 s (- remtries 1)
edc0: 29 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c ).. (thread-sl
edd0: 65 65 70 21 20 31 30 29 0a 09 20 20 20 28 74 65 eep! 10).. (te
ede0: 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 sts:set-full-met
edf0: 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 a-info db test-i
ee00: 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 d run-id minutes
ee10: 20 77 6f 72 6b 2d 61 72 65 61 20 28 2d 20 72 65 work-area (- re
ee20: 6d 74 72 69 65 73 20 31 29 29 29 0a 09 20 28 6c mtries 1))).. (l
ee30: 65 74 20 28 28 65 72 72 2d 73 74 61 74 75 73 20 et ((err-status
ee40: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
ee50: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 erty-accessor 's
ee60: 71 6c 69 74 65 33 20 27 73 74 61 74 75 73 20 23 qlite3 'status #
ee70: 66 29 20 65 78 6e 29 29 29 0a 09 20 20 20 28 64 f) exn))).. (d
ee80: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
ee90: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
eea0: 70 6f 72 74 2a 20 22 74 72 69 65 64 20 66 6f 72 port* "tried for
eeb0: 20 6f 76 65 72 20 61 20 6d 69 6e 75 74 65 20 74 over a minute t
eec0: 6f 20 75 70 64 61 74 65 20 6d 65 74 61 20 69 6e o update meta in
eed0: 66 6f 20 61 6e 64 20 66 61 69 6c 65 64 2e 20 47 fo and failed. G
eee0: 69 76 69 6e 67 20 75 70 22 29 0a 09 20 20 20 28 iving up").. (
eef0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
ef00: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ef10: 20 22 45 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 "EXCEPTION: dat
ef20: 61 62 61 73 65 20 70 72 6f 62 61 62 6c 79 20 6f abase probably o
ef30: 76 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 verloaded or unr
ef40: 65 61 64 61 62 6c 65 2e 22 29 0a 09 20 20 20 28 eadable.").. (
ef50: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
ef60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ef70: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
ef80: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
ef90: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
efa0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
efb0: 0a 09 20 20 20 28 70 72 69 6e 74 20 22 65 78 6e .. (print "exn
efc0: 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c =" (condition->l
efd0: 69 73 74 20 65 78 6e 29 29 0a 09 20 20 20 28 64 ist exn)).. (d
efe0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
eff0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
f000: 22 20 73 74 61 74 75 73 3a 20 20 22 20 28 28 63 " status: " ((c
f010: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
f020: 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 y-accessor 'sqli
f030: 74 65 33 20 27 73 74 61 74 75 73 29 20 65 78 6e te3 'status) exn
f040: 29 29 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 )).. (print-ca
f050: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
f060: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 29 t-error-port))))
f070: 0a 20 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 . (tests:upd
f080: 61 74 65 2d 74 65 73 74 64 61 74 2d 6d 65 74 61 ate-testdat-meta
f090: 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 -info db test-id
f0a0: 20 77 6f 72 6b 2d 61 72 65 61 20 63 70 75 6c 6f work-area cpulo
f0b0: 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 ad diskfree minu
f0c0: 74 65 73 29 0a 20 20 29 29 29 0a 09 20 0a 3b 3b tes). ))).. .;;
f0d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f110: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 ======.;; A R C
f120: 48 20 49 20 56 20 49 20 4e 20 47 0a 3b 3b 3d 3d H I V I N G.;;==
f130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f170: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 74 ====..(define (t
f180: 65 73 74 3a 61 72 63 68 69 76 65 20 64 62 20 74 est:archive db t
f190: 65 73 74 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 est-id). #f)..(
f1a0: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 define (test:arc
f1b0: 68 69 76 65 2d 74 65 73 74 73 20 64 62 20 6b 65 hive-tests db ke
f1c0: 79 6e 61 6d 65 73 20 74 61 72 67 65 74 29 0a 20 ynames target).
f1d0: 20 23 66 29 0a 0a #f)..