Artifact
7bcb24f541f2e9d46f3a2086a7813413f4379589
File
old-runs.scm
— part of check-in
[aaf143afd7]
at
2011-11-16 20:51:28
on branch reorg-runs-code
— Reorg runs code start
(user:
matt
size: 14616)
[more...]
0000: 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 65 ;; register a te
0010: 73 74 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 st run with the
0020: 64 62 0a 28 64 65 66 69 6e 65 20 28 72 65 67 69 db.(define (regi
0030: 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 ster-run db keys
0040: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a ) ;; test-name).
0050: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 74 72 (let* ((keystr
0060: 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 73 74 (keys->keyst
0070: 72 20 6b 65 79 73 29 29 0a 09 20 28 63 6f 6d 6d r keys)).. (comm
0080: 61 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 a (if (> (le
0090: 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 2c ngth keys) 0) ",
00a0: 22 20 22 22 29 29 0a 09 20 28 61 6e 64 73 74 72 " "")).. (andstr
00b0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
00c0: 74 68 20 6b 65 79 73 29 20 30 29 20 22 20 41 4e th keys) 0) " AN
00d0: 44 20 22 20 22 22 29 29 0a 09 20 28 76 61 6c 73 D " "")).. (vals
00e0: 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 61 6c lots (keys->val
00f0: 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b 3b 20 slots keys)) ;;
0100: 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 ?,?,? ..... (key
0110: 76 61 6c 6c 73 74 20 28 6b 65 79 73 2d 3e 76 61 vallst (keys->va
0120: 6c 6c 69 73 74 20 6b 65 79 73 29 29 20 3b 3b 20 llist keys)) ;;
0130: 65 78 74 72 61 63 74 73 20 74 68 65 20 76 61 6c extracts the val
0140: 75 65 73 20 66 72 6f 6d 20 72 65 6d 61 69 6e 64 ues from remaind
0150: 65 72 20 6f 66 20 28 61 72 67 76 29 0a 09 20 28 er of (argv).. (
0160: 72 75 6e 6e 61 6d 65 20 20 20 28 67 65 74 2d 77 runname (get-w
0170: 69 74 68 2d 64 65 66 61 75 6c 74 20 22 3a 72 75 ith-default ":ru
0180: 6e 6e 61 6d 65 22 20 23 66 29 29 0a 09 20 28 73 nname" #f)).. (s
0190: 74 61 74 65 20 20 20 20 20 28 67 65 74 2d 77 69 tate (get-wi
01a0: 74 68 2d 64 65 66 61 75 6c 74 20 22 3a 73 74 61 th-default ":sta
01b0: 74 65 22 20 22 6e 6f 22 29 29 0a 09 20 28 73 74 te" "no")).. (st
01c0: 61 74 75 73 20 20 20 20 28 67 65 74 2d 77 69 74 atus (get-wit
01d0: 68 2d 64 65 66 61 75 6c 74 20 22 3a 73 74 61 74 h-default ":stat
01e0: 75 73 22 20 22 6e 2f 61 22 29 29 0a 09 20 28 61 us" "n/a")).. (a
01f0: 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 llvals (append
0200: 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 20 73 (list runname s
0210: 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 tate status user
0220: 29 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 ) keyvallst))..
0230: 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 70 65 (qryvals (appe
0240: 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 nd (list runname
0250: 29 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 ) keyvallst))..
0260: 28 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 (key=?str (stri
0270: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
0280: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 map (lambda (k)(
0290: 63 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 conc (key:get-fi
02a0: 65 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 eldname k) "=?")
02b0: 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 ) keys) " AND ")
02c0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
02d0: 69 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b int 3 "keys: " k
02e0: 65 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 eys " allvals: "
02f0: 20 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 allvals " keyva
0300: 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 llst: " keyvalls
0310: 74 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 t). (debug:pr
0320: 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 75 73 69 int 2 "NOTE: usi
0330: 6e 67 20 6b 65 79 20 22 20 28 73 74 72 69 6e 67 ng key " (string
0340: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 -intersperse key
0350: 76 61 6c 6c 73 74 20 22 2f 22 29 20 22 20 66 6f vallst "/") " fo
0360: 72 20 74 68 69 73 20 72 75 6e 22 29 0a 20 20 20 r this run").
0370: 20 28 69 66 20 28 61 6e 64 20 72 75 6e 6e 61 6d (if (and runnam
0380: 65 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 e (null? (filter
0390: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 (lambda (x)(not
03a0: 20 78 29 29 20 6b 65 79 76 61 6c 6c 73 74 29 29 x)) keyvallst))
03b0: 29 20 3b 3b 20 74 68 65 72 65 20 6d 75 73 74 20 ) ;; there must
03c0: 62 65 20 61 20 62 65 74 74 65 72 20 77 61 79 20 be a better way
03d0: 74 6f 20 22 61 70 70 6c 79 20 61 6e 64 22 0a 09 to "apply and"..
03e0: 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a (let ((res #f)).
03f0: 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 . (apply sqlite
0400: 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 3:execute db (co
0410: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 49 47 nc "INSERT OR IG
0420: 4e 4f 52 45 20 49 4e 54 4f 20 72 75 6e 73 20 28 NORE INTO runs (
0430: 72 75 6e 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 runname,state,st
0440: 61 74 75 73 2c 6f 77 6e 65 72 2c 65 76 65 6e 74 atus,owner,event
0450: 5f 74 69 6d 65 22 20 63 6f 6d 6d 61 20 6b 65 79 _time" comma key
0460: 73 74 72 20 22 29 20 56 41 4c 55 45 53 20 28 3f str ") VALUES (?
0470: 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 ,?,?,?,strftime(
0480: 27 25 73 27 2c 27 6e 6f 77 27 29 22 20 63 6f 6d '%s','now')" com
0490: 6d 61 20 76 61 6c 73 6c 6f 74 73 20 22 29 3b 22 ma valslots ");"
04a0: 29 0a 09 09 20 61 6c 6c 76 61 6c 73 29 0a 09 20 )... allvals)..
04b0: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
04c0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 for-each-row ..
04d0: 20 20 28 6c 61 6d 62 64 61 20 28 69 64 29 0a 09 (lambda (id)..
04e0: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 69 (set! res i
04f0: 64 29 29 0a 09 20 20 20 64 62 0a 09 20 20 20 28 d)).. db.. (
0500: 6c 65 74 20 28 28 71 72 79 20 28 63 6f 6e 63 20 let ((qry (conc
0510: 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
0520: 72 75 6e 73 20 57 48 45 52 45 20 28 72 75 6e 6e runs WHERE (runn
0530: 61 6d 65 3d 3f 20 22 20 61 6e 64 73 74 72 20 6b ame=? " andstr k
0540: 65 79 3d 3f 73 74 72 20 22 29 3b 22 29 29 29 0a ey=?str ");"))).
0550: 09 20 20 20 20 20 3b 28 64 65 62 75 67 3a 70 72 . ;(debug:pr
0560: 69 6e 74 20 34 20 22 71 72 79 3a 20 22 20 71 72 int 4 "qry: " qr
0570: 79 29 20 0a 09 20 20 20 20 20 71 72 79 29 0a 09 y) .. qry)..
0580: 20 20 20 71 72 79 76 61 6c 73 29 0a 09 20 20 28 qryvals).. (
0590: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
05a0: 64 62 20 22 55 50 44 41 54 45 20 72 75 6e 73 20 db "UPDATE runs
05b0: 53 45 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 74 SET state=?,stat
05c0: 75 73 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b us=? WHERE id=?;
05d0: 22 20 73 74 61 74 65 20 73 74 61 74 75 73 20 72 " state status r
05e0: 65 73 29 0a 09 20 20 72 65 73 29 20 0a 09 28 62 es).. res) ..(b
05f0: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
0600: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 rint 0 "ERROR: C
0610: 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 61 6c alled without al
0620: 6c 20 6e 65 63 65 73 73 61 72 79 20 6b 65 79 73 l necessary keys
0630: 22 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 3b 3b ").. #f))))..;;
0640: 20 54 68 69 73 20 69 73 20 6f 72 69 67 69 6e 61 This is origina
0650: 6c 20 72 75 6e 2d 74 65 73 74 73 2c 20 74 68 69 l run-tests, thi
0660: 73 20 72 6f 75 74 69 6e 65 20 69 73 20 64 65 70 s routine is dep
0670: 72 65 63 61 74 65 64 20 61 6e 64 20 77 65 20 77 recated and we w
0680: 69 6c 6c 20 74 72 61 6e 73 69 74 69 6f 6e 20 74 ill transition t
0690: 6f 20 75 73 69 6e 67 20 72 75 6e 73 3a 72 75 6e o using runs:run
06a0: 2d 74 65 73 74 73 20 28 73 65 65 20 62 65 6c 6f -tests (see belo
06b0: 77 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 w).;;.(define (r
06c0: 75 6e 2d 74 65 73 74 73 20 64 62 20 74 65 73 74 un-tests db test
06d0: 2d 6e 61 6d 65 73 29 0a 20 20 28 6c 65 74 2a 20 -names). (let*
06e0: 28 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 64 ((keys (d
06f0: 62 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b-get-keys db)).
0700: 09 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 . (keyvallst (
0710: 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 keys->vallist ke
0720: 79 73 20 23 74 29 29 0a 09 20 28 72 75 6e 2d 69 ys #t)).. (run-i
0730: 64 20 20 20 20 20 20 28 72 65 67 69 73 74 65 72 d (register
0740: 2d 72 75 6e 20 64 62 20 6b 65 79 73 29 29 20 20 -run db keys))
0750: 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ;; test-name)))
0760: 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 20 .. (deferred
0770: 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 '()) ;; delay ru
0780: 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 nning these sinc
0790: 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 e they have a wa
07a0: 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 28 72 iton clause.. (r
07b0: 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f 6e unconfigf (con
07c0: 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 c *toppath* "/r
07d0: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
07e0: 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 2d ")).. (required-
07f0: 74 65 73 74 73 20 27 28 29 29 29 0a 0a 20 20 20 tests '()))..
0800: 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f 6e 2d ;; now add non-
0810: 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 65 6e directly referen
0820: 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 65 73 ced dependencies
0830: 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 0a 20 (i.e. waiton).
0840: 20 20 20 3b 3b 20 63 6f 75 6c 64 20 63 61 63 68 ;; could cach
0850: 65 20 61 6c 6c 20 74 68 65 73 65 20 73 69 6e 63 e all these sinc
0860: 65 20 74 68 65 79 20 6e 65 65 64 20 74 6f 20 62 e they need to b
0870: 65 20 72 65 61 64 20 61 67 61 69 6e 20 2e 2e 2e e read again ...
0880: 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 20 53 4f . ;; FIXME SO
0890: 4d 45 44 41 59 0a 20 20 20 20 28 69 66 20 28 6e MEDAY. (if (n
08a0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e ot (null? test-n
08b0: 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f ames))..(let loo
08c0: 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 p ((hed (car tes
08d0: 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 t-names))... (
08e0: 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e 61 tal (cdr test-na
08f0: 6d 65 73 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 mes))).. (let*
0900: 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 3a ((config (test:
0910: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 get-testconfig h
0920: 65 64 20 23 66 29 29 0a 09 09 20 28 77 61 69 74 ed #f))... (wait
0930: 6f 6e 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ons (string-spli
0940: 74 20 28 6c 65 74 20 28 28 77 20 28 63 6f 6e 66 t (let ((w (conf
0950: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
0960: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
0970: 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 09 09 "waiton"))).....
0980: 09 20 20 28 69 66 20 77 20 77 20 22 22 29 29 29 . (if w w "")))
0990: 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 )).. (for-eac
09a0: 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 h .. (lambda
09b0: 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 (waiton)..
09c0: 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f (if (and waito
09d0: 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 n (not (member w
09e0: 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
09f0: 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a )))... (begin.
0a00: 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 71 .. (set! req
0a10: 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e uired-tests (con
0a20: 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 s waiton require
0a30: 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 d-tests))...
0a40: 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
0a50: 73 20 28 61 70 70 65 6e 64 20 74 65 73 74 2d 6e s (append test-n
0a60: 61 6d 65 73 20 28 6c 69 73 74 20 77 61 69 74 6f ames (list waito
0a70: 6e 29 29 29 29 29 29 0a 09 20 20 20 20 20 77 61 n)))))).. wa
0a80: 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 itons).. (let
0a90: 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c ((remtests (del
0aa0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
0ab0: 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 append waitons t
0ac0: 61 6c 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 al)))).. (i
0ad0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 f (not (null? re
0ae0: 6d 74 65 73 74 73 29 29 0a 09 09 20 20 28 6c 6f mtests))... (lo
0af0: 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 op (car remtests
0b00: 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 )(cdr remtests))
0b10: 29 29 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 ))))).. (if (
0b20: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 not (null? requi
0b30: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 28 64 65 red-tests))..(de
0b40: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 bug:print 1 "INF
0b50: 4f 3a 20 41 64 64 69 6e 67 20 22 20 72 65 71 75 O: Adding " requ
0b60: 69 72 65 64 2d 74 65 73 74 73 20 22 20 74 6f 20 ired-tests " to
0b70: 74 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 0a the run queue").
0b80: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 .(debug:print 1
0b90: 22 49 4e 46 4f 3a 20 4e 6f 20 70 72 65 72 65 71 "INFO: No prereq
0ba0: 75 69 73 69 74 65 73 20 61 64 64 65 64 22 29 29 uisites added"))
0bb0: 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 .. ;; on the
0bc0: 66 69 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 first pass or ca
0bd0: 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 ll to run-tests
0be0: 73 65 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 set FAILS to NOT
0bf0: 5f 53 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 _STARTED if.
0c00: 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 ;; -keepgoing is
0c10: 20 73 70 65 63 69 66 69 65 64 0a 0a 20 20 20 20 specified..
0c20: 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e (set-megatest-en
0c30: 76 2d 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 v-vars db run-id
0c40: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
0c50: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
0c60: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
0c70: 73 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 28 s. . (if (
0c80: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
0c90: 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 70 configf)..(setup
0ca0: 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 62 -env-defaults db
0cb0: 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d runconfigf run-
0cc0: 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e id *already-seen
0cd0: 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a -runconfig-info*
0ce0: 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 22 environ-patt: "
0cf0: 2e 2a 22 29 0a 09 28 64 65 62 75 67 3a 70 72 69 .*")..(debug:pri
0d00: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 59 nt 0 "WARNING: Y
0d10: 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 61 ou do not have a
0d20: 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 run config file
0d30: 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 29 : " runconfigf))
0d40: 0a 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
0d50: 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 eq? *passnum* 0)
0d60: 0a 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 .. (args:get
0d70: 2d 61 72 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 -arg "-keepgoing
0d80: 22 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b "))..(begin.. ;
0d90: 3b 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 65 ; have to delete
0da0: 20 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 68 test records wh
0db0: 65 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 ere NOT_STARTED
0dc0: 73 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 63 since they can c
0dd0: 61 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 ause -keepgoing
0de0: 74 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 to .. ;; get st
0df0: 75 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f 6d uck due to becom
0e00: 69 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c 65 ing inaccessible
0e10: 20 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 from a failed t
0e20: 65 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 est. I.e. if tes
0e30: 74 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 20 t B depends ..
0e40: 3b 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 74 ;; on test A but
0e50: 20 74 65 73 74 20 42 20 72 65 61 63 68 65 64 20 test B reached
0e60: 74 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 the point on bei
0e70: 6e 67 20 72 65 67 69 73 74 65 72 65 64 20 61 73 ng registered as
0e80: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 NOT_STARTED and
0e90: 20 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 test.. ;; A fa
0ea0: 69 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 iled for some re
0eb0: 61 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d ason then on re-
0ec0: 72 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 run using -keepg
0ed0: 6f 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 6e oing the run can
0ee0: 20 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e never complete.
0ef0: 0a 09 20 20 28 64 62 3a 64 65 6c 65 74 65 2d 74 .. (db:delete-t
0f00: 65 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 64 62 ests-in-state db
0f10: 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 run-id "NOT_STA
0f20: 52 54 45 44 22 29 0a 09 20 20 28 64 62 3a 73 65 RTED").. (db:se
0f30: 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 t-tests-state-st
0f40: 61 74 75 73 20 64 62 20 72 75 6e 2d 69 64 20 74 atus db run-id t
0f50: 65 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 est-names #f "FA
0f60: 49 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 IL" "NOT_STARTED
0f70: 22 20 22 46 41 49 4c 22 29 29 29 0a 20 20 20 20 " "FAIL"))).
0f80: 28 73 65 74 21 20 2a 70 61 73 73 6e 75 6d 2a 20 (set! *passnum*
0f90: 28 2b 20 2a 70 61 73 73 6e 75 6d 2a 20 31 29 29 (+ *passnum* 1))
0fa0: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
0fb0: 28 6e 75 6d 74 69 6d 65 73 20 30 29 29 0a 20 20 (numtimes 0)).
0fc0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
0fd0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 (lambda (t
0fe0: 65 73 74 2d 6e 61 6d 65 29 0a 09 20 28 69 66 20 est-name).. (if
0ff0: 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f (runs:can-run-mo
1000: 72 65 2d 74 65 73 74 73 20 64 62 29 0a 09 20 20 re-tests db)..
1010: 20 20 20 28 72 75 6e 2d 6f 6e 65 2d 74 65 73 74 (run-one-test
1020: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
1030: 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 29 0a name keyvallst).
1040: 09 20 20 20 20 20 3b 3b 20 61 64 64 20 73 6f 6d . ;; add som
1050: 65 20 64 65 6c 61 79 20 0a 09 20 20 20 20 20 3b e delay .. ;
1060: 28 73 6c 65 65 70 20 32 29 0a 09 20 20 20 20 20 (sleep 2)..
1070: 29 29 0a 20 20 20 20 20 20 20 28 74 65 73 74 73 )). (tests
1080: 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 :sort-by-priorit
1090: 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 y-and-waiton tes
10a0: 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 20 t-names)).
10b0: 3b 3b 20 28 72 75 6e 2d 77 61 69 74 69 6e 67 2d ;; (run-waiting-
10c0: 74 65 73 74 73 20 64 62 29 0a 20 20 20 20 20 20 tests db).
10d0: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
10e0: 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 0a g "-keepgoing").
10f0: 09 20 20 28 6c 65 74 20 28 28 65 73 74 72 65 6d . (let ((estrem
1100: 20 28 64 62 3a 65 73 74 69 6d 61 74 65 64 2d 74 (db:estimated-t
1110: 65 73 74 73 2d 72 65 6d 61 69 6e 69 6e 67 20 64 ests-remaining d
1120: 62 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 20 b run-id)))..
1130: 20 28 69 66 20 28 61 6e 64 20 28 3e 20 65 73 74 (if (and (> est
1140: 72 65 6d 20 30 29 0a 09 09 20 20 20 20 20 28 65 rem 0)... (e
1150: 71 3f 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 q? *globalexitst
1160: 61 74 75 73 2a 20 30 29 29 0a 09 09 28 62 65 67 atus* 0))...(beg
1170: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
1180: 69 6e 74 20 31 20 22 4b 65 65 70 20 67 6f 69 6e int 1 "Keep goin
1190: 67 2c 20 65 73 74 69 6d 61 74 65 64 20 22 20 65 g, estimated " e
11a0: 73 74 72 65 6d 20 22 20 74 65 73 74 73 20 72 65 strem " tests re
11b0: 6d 61 69 6e 69 6e 67 20 74 6f 20 72 75 6e 2c 20 maining to run,
11c0: 77 69 6c 6c 20 63 6f 6e 74 69 6e 75 65 20 69 6e will continue in
11d0: 20 33 20 73 65 63 6f 6e 64 73 20 2e 2e 2e 22 29 3 seconds ...")
11e0: 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
11f0: 65 70 21 20 33 29 0a 09 09 20 20 28 72 75 6e 2d ep! 3)... (run-
1200: 77 61 69 74 69 6e 67 2d 74 65 73 74 73 20 64 62 waiting-tests db
1210: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 6e )... (loop (+ n
1220: 75 6d 74 69 6d 65 73 20 31 29 29 29 29 29 29 29 umtimes 1)))))))
1230: 29 29 0a 09 20 20 0a 3b 3b 20 56 45 52 59 20 49 )).. .;; VERY I
1240: 4e 45 46 46 49 43 49 45 4e 54 21 20 4d 6f 76 65 NEFFICIENT! Move
1250: 20 73 74 75 66 66 20 74 68 61 74 20 73 68 6f 75 stuff that shou
1260: 6c 64 20 62 65 20 64 6f 6e 65 20 6f 6e 63 65 20 ld be done once
1270: 75 70 20 74 6f 20 63 61 6c 6c 69 6e 67 20 70 72 up to calling pr
1280: 6f 63 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 2d oc.(define (run-
1290: 6f 6e 65 2d 74 65 73 74 20 64 62 20 72 75 6e 2d one-test db run-
12a0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6b 65 79 id test-name key
12b0: 76 61 6c 6c 73 74 29 0a 20 20 28 64 65 62 75 67 vallst). (debug
12c0: 3a 70 72 69 6e 74 20 31 20 22 4c 61 75 6e 63 68 :print 1 "Launch
12d0: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
12e0: 6e 61 6d 65 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 name). ;; All t
12f0: 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 hese vars might
1300: 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 be referenced by
1310: 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 the testconfig
1320: 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 28 73 file reader. (s
1330: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
1340: 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 AME" test-name)
1350: 3b 3b 20 0a 20 20 28 73 65 74 65 6e 76 20 22 4d ;; . (setenv "M
1360: 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 28 61 72 T_RUNNAME" (ar
1370: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e gs:get-arg ":run
1380: 6e 61 6d 65 22 29 29 0a 0a 20 20 3b 3b 20 28 73 name")).. ;; (s
1390: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
13a0: 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 20 vars db run-id)
13b0: 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 ;; these may be
13c0: 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 needed by the la
13d0: 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a unching process.
13e0: 0a 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 . (change-direc
13f0: 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a tory *toppath*).
1400: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 (let* ((test-p
1410: 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f ath (conc *to
1420: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 ppath* "/tests/"
1430: 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 test-name)) ;;
1440: 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 3a 67 could use test:g
1450: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
1460: 72 65 20 2e 2e 2e 0a 09 20 28 74 65 73 74 2d 63 re ..... (test-c
1470: 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 onfigf (conc tes
1480: 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e t-path "/testcon
1490: 66 69 67 22 29 29 0a 09 20 28 74 65 73 74 65 78 fig")).. (testex
14a0: 69 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c ists (and (fil
14b0: 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 e-exists? test-c
14c0: 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 onfigf)(file-rea
14d0: 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 d-access? test-c
14e0: 6f 6e 66 69 67 66 29 29 29 0a 09 20 28 74 65 73 onfigf))).. (tes
14f0: 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 t-conf (if te
1500: 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 stexists (read-c
1510: 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 onfig test-confi
1520: 67 66 20 23 66 20 23 74 29 20 28 6d 61 6b 65 2d gf #f #t) (make-
1530: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 hash-table)))..
1540: 28 77 61 69 74 6f 6e 20 20 20 20 20 20 20 28 6c (waiton (l
1550: 65 74 20 28 28 77 20 28 63 6f 6e 66 69 67 2d 6c et ((w (config-l
1560: 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
1570: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
1580: 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 09 20 28 waiton"))).... (
1590: 69 66 20 28 73 74 72 69 6e 67 3f 20 77 29 28 73 if (string? w)(s
15a0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 77 29 27 28 tring-split w)'(
15b0: 29 29 29 29 0a 09 20 28 74 61 67 73 20 20 20 20 )))).. (tags
15c0: 20 20 20 20 20 28 6c 65 74 20 28 28 74 20 28 63 (let ((t (c
15d0: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 onfig-lookup tes
15e0: 74 2d 63 6f 6e 66 20 22 73 65 74 75 70 22 20 22 t-conf "setup" "
15f0: 74 61 67 73 22 29 29 29 0a 09 09 09 20 3b 3b 20 tags"))).... ;;
1600: 77 65 20 77 61 6e 74 20 6f 75 72 20 74 61 67 73 we want our tags
1610: 20 74 6f 20 62 65 20 73 65 70 61 72 61 74 65 64 to be separated
1620: 20 62 79 20 63 6f 6d 6d 61 73 20 61 6e 64 20 66 by commas and f
1630: 75 6c 6c 79 20 64 65 6c 69 6d 69 74 65 64 20 62 ully delimited b
1640: 79 20 63 6f 6d 6d 61 73 0a 09 09 09 20 3b 3b 20 y commas.... ;;
1650: 73 6f 20 74 68 61 74 20 71 75 65 72 69 65 73 20 so that queries
1660: 77 69 74 68 20 22 6c 69 6b 65 22 20 63 61 6e 20 with "like" can
1670: 74 69 65 20 74 6f 20 74 68 65 20 63 6f 6d 6d 61 tie to the comma
1680: 73 20 61 74 20 65 69 74 68 65 72 20 65 6e 64 20 s at either end
1690: 6f 66 20 65 61 63 68 20 74 61 67 0a 09 09 09 20 of each tag....
16a0: 3b 3b 20 77 68 69 6c 65 20 61 6c 73 6f 20 61 6c ;; while also al
16b0: 6c 6f 77 69 6e 67 20 74 68 65 20 65 6e 64 20 75 lowing the end u
16c0: 73 65 72 20 74 6f 20 66 72 65 65 6c 79 20 75 73 ser to freely us
16d0: 65 20 73 70 61 63 65 73 20 61 6e 64 20 63 6f 6d e spaces and com
16e0: 6d 61 73 20 74 6f 20 73 65 70 61 72 61 74 65 20 mas to separate
16f0: 74 61 67 73 0a 09 09 09 20 28 69 66 20 28 73 74 tags.... (if (st
1700: 72 69 6e 67 3f 20 74 29 28 73 74 72 69 6e 67 2d ring? t)(string-
1710: 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 substitute (rege
1720: 78 70 20 22 5b 2c 5c 5c 73 5d 2b 22 29 20 22 2c xp "[,\\s]+") ",
1730: 22 20 28 63 6f 6e 63 20 22 2c 22 20 74 20 22 2c " (conc "," t ",
1740: 22 29 20 23 74 29 0a 09 09 09 20 20 20 20 20 27 ") #t).... '
1750: 28 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 ())))). (if (
1760: 6e 6f 74 20 74 65 73 74 65 78 69 73 74 73 29 0a not testexists).
1770: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
1780: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
1790: 3a 20 43 61 6e 27 74 20 66 69 6e 64 20 63 6f 6e : Can't find con
17a0: 66 69 67 20 66 69 6c 65 20 22 20 74 65 73 74 2d fig file " test-
17b0: 63 6f 6e 66 69 67 66 29 0a 09 20 20 28 65 78 69 configf).. (exi
17c0: 74 20 32 29 29 0a 09 3b 3b 20 70 75 74 20 74 6f t 2))..;; put to
17d0: 70 20 76 61 72 73 20 69 6e 74 6f 20 63 6f 6e 76 p vars into conv
17e0: 65 6e 69 65 6e 74 20 76 61 72 69 61 62 6c 65 73 enient variables
17f0: 20 61 6e 64 20 6f 70 65 6e 20 74 68 65 20 64 62 and open the db
1800: 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 64 62 20 69 ..(let* (;; db i
1810: 73 20 61 6c 77 61 79 73 20 61 74 20 2a 74 6f 70 s always at *top
1820: 70 61 74 68 2a 2f 64 62 2f 6d 65 67 61 74 65 73 path*/db/megates
1830: 74 2e 64 62 0a 09 20 20 20 20 20 20 20 28 69 74 t.db.. (it
1840: 65 6d 73 20 20 20 20 20 20 20 28 68 61 73 68 2d ems (hash-
1850: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1860: 74 20 74 65 73 74 2d 63 6f 6e 66 20 22 69 74 65 t test-conf "ite
1870: 6d 73 22 20 27 28 29 29 29 0a 09 20 20 20 20 20 ms" '()))..
1880: 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 20 28 (itemstable (
1890: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
18a0: 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e 66 efault test-conf
18b0: 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 27 28 "itemstable" '(
18c0: 29 29 29 0a 09 20 20 20 20 20 20 20 28 61 6c 6c ))).. (all
18d0: 69 74 65 6d 73 20 20 20 20 28 69 66 20 28 6f 72 items (if (or
18e0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 74 65 (not (null? ite
18f0: 6d 73 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 ms))(not (null?
1900: 69 74 65 6d 73 74 61 62 6c 65 29 29 29 0a 09 09 itemstable)))...
1910: 09 09 28 61 70 70 65 6e 64 20 28 69 74 65 6d 2d ..(append (item-
1920: 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 assoc->item-list
1930: 20 69 74 65 6d 73 29 0a 09 09 09 09 09 28 69 74 items)......(it
1940: 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c em-table->item-l
1950: 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 29 ist itemstable))
1960: 0a 09 09 09 09 27 28 28 29 29 29 29 29 20 3b 3b .....'(())))) ;;
1970: 20 61 20 6c 69 73 74 20 77 69 74 68 20 6f 6e 65 a list with one
1980: 20 6e 75 6c 6c 20 6c 69 73 74 20 69 73 20 61 20 null list is a
1990: 74 65 73 74 20 77 69 74 68 20 6e 6f 20 69 74 65 test with no ite
19a0: 6d 73 0a 3b 3b 20 09 20 20 28 72 75 6e 63 6f 6e ms.;; . (runcon
19b0: 66 69 67 66 20 20 28 63 6f 6e 63 20 20 2a 74 6f figf (conc *to
19c0: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
19d0: 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 29 0a 09 igs.config")))..
19e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
19f0: 20 22 69 74 65 6d 73 3a 20 22 29 0a 09 20 20 28 "items: ").. (
1a00: 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 if (>= *verbosit
1a10: 79 2a 20 31 29 28 70 70 20 61 6c 6c 69 74 65 6d y* 1)(pp allitem
1a20: 73 29 29 0a 09 20 20 28 69 66 20 28 3e 3d 20 2a s)).. (if (>= *
1a30: 76 65 72 62 6f 73 69 74 79 2a 20 35 29 0a 09 20 verbosity* 5)..
1a40: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 70 (begin...(p
1a50: 72 69 6e 74 20 22 69 74 65 6d 73 3a 20 22 29 28 rint "items: ")(
1a60: 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e pp (item-assoc->
1a70: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 item-list items)
1a80: 29 0a 09 09 28 70 72 69 6e 74 20 22 69 74 65 73 )...(print "ites
1a90: 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 69 74 table: ")(pp (it
1aa0: 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c em-table->item-l
1ab0: 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 29 ist itemstable))
1ac0: 29 29 0a 09 20 20 28 69 66 20 28 61 72 67 73 3a )).. (if (args:
1ad0: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 0a 09 20 get-arg "-m")..
1ae0: 20 20 20 20 20 28 64 62 3a 73 65 74 2d 63 6f 6d (db:set-com
1af0: 6d 65 6e 74 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ment-for-run db
1b00: 72 75 6e 2d 69 64 20 28 61 72 67 73 3a 67 65 74 run-id (args:get
1b10: 2d 61 72 67 20 22 2d 6d 22 29 29 29 0a 0a 09 20 -arg "-m")))...
1b20: 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 72 ;; Here is wher
1b30: 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 e the test_meta
1b40: 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 70 table is best up
1b50: 64 61 74 65 64 0a 09 20 20 28 72 75 6e 73 3a 75 dated.. (runs:u
1b60: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
1b70: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 db test-name tes
1b80: 74 2d 63 6f 6e 66 29 0a 0a 09 20 20 3b 3b 20 62 t-conf)... ;; b
1b90: 72 61 69 6e 64 65 61 64 20 77 6f 72 6b 2d 61 72 raindead work-ar
1ba0: 6f 75 6e 64 20 66 6f 72 20 70 6f 6f 72 6c 79 20 ound for poorly
1bb0: 73 70 65 63 69 66 69 65 64 20 61 6c 6c 69 74 65 specified allite
1bc0: 6d 73 20 6c 69 73 74 20 42 55 47 21 21 21 20 46 ms list BUG!!! F
1bd0: 49 58 4d 45 0a 09 20 20 28 69 66 20 28 6e 75 6c IXME.. (if (nul
1be0: 6c 3f 20 61 6c 6c 69 74 65 6d 73 29 28 73 65 74 l? allitems)(set
1bf0: 21 20 61 6c 6c 69 74 65 6d 73 20 27 28 28 29 29 ! allitems '(())
1c00: 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 )).. (let loop
1c10: 28 28 69 74 65 6d 64 61 74 20 28 63 61 72 20 61 ((itemdat (car a
1c20: 6c 6c 69 74 65 6d 73 29 29 0a 09 09 20 20 20 20 llitems))...
1c30: 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 61 (tal (cdr a
1c40: 6c 6c 69 74 65 6d 73 29 29 29 0a 09 20 20 20 20 llitems)))..
1c50: 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ;; (lambda (item
1c60: 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e dat) ;;; ((ripen
1c70: 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 ess "overripe")
1c80: 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f (temperature "co
1c90: 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 ol") (season "su
1ca0: 6d 6d 65 72 22 29 29 0a 09 20 20 20 20 3b 3b 20 mmer")).. ;;
1cb0: 48 61 6e 64 6c 65 20 6c 69 73 74 73 20 6f 66 20 Handle lists of
1cc0: 69 74 65 6d 73 0a 09 20 20 20 20 28 6c 65 74 2a items.. (let*
1cd0: 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 ((item-path
1ce0: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
1cf0: 68 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 28 h itemdat)) ;; (
1d00: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
1d10: 73 65 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 se (map cadr ite
1d20: 6d 64 61 74 29 20 22 2f 22 29 29 0a 09 09 20 20 mdat) "/"))...
1d30: 20 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 (new-test-path
1d40: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
1d50: 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 rse (cons test-p
1d60: 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 ath (map cadr it
1d70: 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 09 emdat)) "/"))...
1d80: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d (new-test-nam
1d90: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
1da0: 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 em-path "") test
1db0: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
1dc0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
1dd0: 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e ath))) ;; just n
1de0: 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 eed it to be uni
1df0: 71 75 65 0a 09 09 20 20 20 28 74 65 73 74 64 61 que... (testda
1e00: 74 20 20 20 23 66 29 0a 09 09 20 20 20 28 6e 75 t #f)... (nu
1e10: 6d 2d 72 75 6e 6e 69 6e 67 20 28 64 62 3a 67 65 m-running (db:ge
1e20: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
1e30: 6e 6e 69 6e 67 20 64 62 29 29 0a 09 09 20 20 20 nning db))...
1e40: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
1e50: 6a 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f jobs (config-loo
1e60: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
1e70: 22 73 65 74 75 70 22 20 22 6d 61 78 5f 63 6f 6e "setup" "max_con
1e80: 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 0a current_jobs")).
1e90: 09 09 20 20 20 28 70 61 72 65 6e 74 2d 74 65 73 .. (parent-tes
1ea0: 74 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c t (and (not (nul
1eb0: 6c 3f 20 69 74 65 6d 73 29 29 28 65 71 75 61 6c l? items))(equal
1ec0: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 ? item-path ""))
1ed0: 29 0a 09 09 20 20 20 28 73 69 6e 67 6c 65 2d 74 )... (single-t
1ee0: 65 73 74 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 est (and (null?
1ef0: 69 74 65 6d 73 29 20 28 65 71 75 61 6c 3f 20 69 items) (equal? i
1f00: 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a 09 tem-path "")))..
1f10: 09 20 20 20 28 69 74 65 6d 2d 74 65 73 74 20 20 . (item-test
1f20: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 (not (equal? it
1f30: 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a 09 09 em-path "")))...
1f40: 20 20 20 28 69 74 65 6d 2d 70 61 74 74 20 20 20 (item-patt
1f50: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
1f60: 69 74 65 6d 70 61 74 74 22 29 29 0a 09 09 20 20 itempatt"))...
1f70: 20 28 70 61 74 74 2d 6d 61 74 63 68 20 20 28 69 (patt-match (i
1f80: 66 20 69 74 65 6d 2d 70 61 74 74 0a 09 09 09 09 f item-patt.....
1f90: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 61 72 (string-sear
1fa0: 63 68 20 28 67 6c 6f 62 2d 3e 72 65 67 65 78 70 ch (glob->regexp
1fb0: 0a 09 09 09 09 09 09 20 20 20 28 73 74 72 69 6e ....... (strin
1fc0: 67 2d 74 72 61 6e 73 6c 61 74 65 20 69 74 65 6d g-translate item
1fd0: 2d 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 0a -patt "%" "*")).
1fe0: 09 09 09 09 09 09 20 20 69 74 65 6d 2d 70 61 74 ...... item-pat
1ff0: 68 29 0a 09 09 09 09 20 20 20 20 23 74 29 29 29 h)..... #t)))
2000: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
2010: 72 69 6e 74 20 33 20 22 6d 61 78 2d 63 6f 6e 63 rint 3 "max-conc
2020: 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d urrent-jobs: " m
2030: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
2040: 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e bs ", num-runnin
2050: 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 g: " num-running
2060: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ).. (if (an
2070: 64 20 70 61 74 74 2d 6d 61 74 63 68 20 28 72 75 d patt-match (ru
2080: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
2090: 74 65 73 74 73 20 64 62 29 29 0a 09 09 20 20 28 tests db))... (
20a0: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 6c 65 74 begin... (let
20b0: 20 6c 6f 6f 70 32 20 28 28 74 73 20 28 64 62 3a loop2 ((ts (db:
20c0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 get-test-info db
20d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
20e0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 20 3b 3b e item-path)) ;;
20f0: 20 23 66 29 0a 09 09 09 09 28 63 74 20 30 29 29 #f).....(ct 0))
2100: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ... (if (an
2110: 64 20 28 6e 6f 74 20 74 73 29 0a 09 09 09 20 20 d (not ts)....
2120: 20 20 20 20 20 28 3c 20 63 74 20 31 30 29 29 0a (< ct 10)).
2130: 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 ... (begin....
2140: 20 20 20 28 72 65 67 69 73 74 65 72 2d 74 65 73 (register-tes
2150: 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 t db run-id test
2160: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
2170: 0a 09 09 09 20 20 20 20 28 64 62 3a 74 65 73 74 .... (db:test
2180: 2d 73 65 74 2d 63 6f 6d 6d 65 6e 74 20 64 62 20 -set-comment db
2190: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
21a0: 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 0a 09 item-path "")..
21b0: 09 09 20 20 20 20 28 6c 6f 6f 70 32 20 28 64 62 .. (loop2 (db
21c0: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 :get-test-info d
21d0: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
21e0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 me item-path)...
21f0: 09 09 20 20 20 28 2b 20 63 74 20 31 29 29 29 0a .. (+ ct 1))).
2200: 09 09 09 20 20 28 69 66 20 74 73 0a 09 09 09 20 ... (if ts....
2210: 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 64 (set! testd
2220: 61 74 20 74 73 29 0a 09 09 09 20 20 20 20 20 20 at ts)....
2230: 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 (begin.....(debu
2240: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
2250: 4e 47 3a 20 43 6f 75 6c 64 6e 27 74 20 72 65 67 NG: Couldn't reg
2260: 69 73 74 65 72 20 74 65 73 74 20 22 20 74 65 73 ister test " tes
2270: 74 2d 6e 61 6d 65 20 22 20 77 69 74 68 20 69 74 t-name " with it
2280: 65 6d 20 70 61 74 68 20 22 20 69 74 65 6d 2d 70 em path " item-p
2290: 61 74 68 20 22 2c 20 73 6b 69 70 70 69 6e 67 22 ath ", skipping"
22a0: 29 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 20 28 ).....(if (not (
22b0: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 null? tal)).....
22c0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
22d0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
22e0: 29 29 0a 09 09 20 20 20 20 28 63 68 61 6e 67 65 ))... (change
22f0: 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d -directory test-
2300: 70 61 74 68 29 0a 09 09 20 20 20 20 3b 3b 20 74 path)... ;; t
2310: 68 69 73 20 62 6c 6f 63 6b 20 69 73 20 68 65 72 his block is her
2320: 65 20 6f 6e 6c 79 20 74 6f 20 69 6e 66 6f 72 6d e only to inform
2330: 20 74 68 65 20 75 73 65 72 20 65 61 72 6c 79 20 the user early
2340: 6f 6e 0a 09 09 20 20 20 20 0a 09 09 20 20 20 20 on... ...
2350: 3b 3b 20 4e 42 2f 2f 20 4d 6f 76 69 6e 67 20 74 ;; NB// Moving t
2360: 68 65 20 73 65 74 74 69 6e 67 20 6f 66 20 72 75 he setting of ru
2370: 6e 63 6f 6e 66 69 67 2e 63 6f 6e 66 69 67 20 76 nconfig.config v
2380: 61 72 73 20 74 6f 20 2a 62 65 66 6f 72 65 2a 20 ars to *before*
2390: 74 68 65 20 0a 09 09 20 20 20 20 3b 3b 20 74 68 the ... ;; th
23a0: 65 20 63 61 6c 6c 69 6e 67 20 6f 66 20 65 61 63 e calling of eac
23b0: 68 20 74 65 73 74 2e 0a 09 09 20 20 20 20 3b 3b h test.... ;;
23c0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
23d0: 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 s? runconfigf)..
23e0: 09 20 20 20 20 3b 3b 20 20 20 20 20 28 73 65 74 . ;; (set
23f0: 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 up-env-defaults
2400: 64 62 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 db runconfigf ru
2410: 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 n-id *already-se
2420: 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 en-runconfig-inf
2430: 6f 2a 29 0a 09 09 20 20 20 20 3b 3b 20 20 20 20 o*)... ;;
2440: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2450: 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f "WARNING: You do
2460: 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e 20 not have a run
2470: 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 72 config file: " r
2480: 75 6e 63 6f 6e 66 69 67 66 29 29 0a 09 09 20 20 unconfigf))...
2490: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
24a0: 20 22 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d "run-id: " run-
24b0: 69 64 20 22 20 74 65 73 74 2d 6e 61 6d 65 3a 20 id " test-name:
24c0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 74 " test-name " it
24d0: 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 6d 2d em-path: " item-
24e0: 70 61 74 68 20 22 20 74 65 73 74 64 61 74 3a 20 path " testdat:
24f0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
2500: 75 73 20 74 65 73 74 64 61 74 29 20 22 20 74 65 us testdat) " te
2510: 73 74 2d 73 74 61 74 65 3a 20 22 20 28 74 65 73 st-state: " (tes
2520: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
2530: 64 61 74 29 29 0a 09 09 20 20 20 20 28 63 61 73 dat))... (cas
2540: 65 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d e (if (args:get-
2550: 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 arg "-force")...
2560: 09 20 20 20 20 20 20 27 4e 4f 54 5f 53 54 41 52 . 'NOT_STAR
2570: 54 45 44 0a 09 09 09 20 20 20 20 20 20 28 69 66 TED.... (if
2580: 20 74 65 73 74 64 61 74 0a 09 09 09 09 20 20 28 testdat..... (
2590: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
25a0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
25b0: 65 73 74 64 61 74 29 29 0a 09 09 09 09 20 20 27 estdat))..... '
25c0: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
25d0: 29 29 0a 09 09 20 20 20 20 20 20 28 28 66 61 69 ))... ((fai
25e0: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 led-to-insert)..
25f0: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
2600: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F
2610: 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 ailed to insert
2620: 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 the record into
2630: 74 68 65 20 64 62 22 29 29 0a 09 09 20 20 20 20 the db"))...
2640: 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 ((NOT_STARTED
2650: 43 4f 4d 50 4c 45 54 45 44 29 0a 09 09 20 20 20 COMPLETED)...
2660: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2670: 20 36 20 22 47 6f 74 20 68 65 72 65 2c 20 22 20 6 "Got here, "
2680: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
2690: 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 testdat))...
26a0: 20 20 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 (let ((runfla
26b0: 67 20 23 66 29 29 0a 09 09 09 20 28 63 6f 6e 64 g #f)).... (cond
26c0: 0a 09 09 09 20 20 3b 3b 20 69 2e 65 2e 20 74 68 .... ;; i.e. th
26d0: 69 73 20 69 73 20 74 68 65 20 70 61 72 65 6e 74 is is the parent
26e0: 20 74 65 73 74 20 74 6f 20 61 20 73 75 69 74 65 test to a suite
26f0: 20 6f 66 20 69 74 65 6d 73 2c 20 6e 65 76 65 72 of items, never
2700: 20 22 72 75 6e 22 20 69 74 0a 09 09 09 20 20 28 "run" it.... (
2710: 70 61 72 65 6e 74 2d 74 65 73 74 0a 09 09 09 20 parent-test....
2720: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
2730: 23 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 66 6f #f)).... ;; -fo
2740: 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 rce, run no matt
2750: 65 72 20 77 68 61 74 0a 09 09 09 20 20 28 28 61 er what.... ((a
2760: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f rgs:get-arg "-fo
2770: 72 63 65 22 29 28 73 65 74 21 20 72 75 6e 66 6c rce")(set! runfl
2780: 61 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 ag #t)).... ;;
2790: 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e NOT_STARTED, run
27a0: 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a no matter what.
27b0: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 74 ... ((equal? (t
27c0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
27d0: 73 74 64 61 74 29 20 22 4e 4f 54 5f 53 54 41 52 stdat) "NOT_STAR
27e0: 54 45 44 22 29 28 73 65 74 21 20 72 75 6e 66 6c TED")(set! runfl
27f0: 61 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 ag #t)).... ;;
2800: 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 not -rerun and P
2810: 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 ASS, WARN or CHE
2820: 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 09 CK, do no run...
2830: 09 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f . ((and (or (no
2840: 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 t (args:get-arg
2850: 22 2d 72 65 72 75 6e 22 29 29 0a 09 09 09 09 20 "-rerun")).....
2860: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
2870: 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 0a "-keepgoing")).
2880: 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 ....(member (tes
2890: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
28a0: 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 22 tdat) '("PASS" "
28b0: 57 41 52 4e 22 20 22 43 48 45 43 4b 22 29 29 29 WARN" "CHECK")))
28c0: 0a 09 09 09 20 20 20 28 73 65 74 21 20 72 75 6e .... (set! run
28d0: 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 3b flag #f)).... ;
28e0: 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 ; -rerun and sta
28f0: 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 tus is one of th
2900: 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 e specifed, run
2910: 69 74 0a 09 09 09 20 20 28 28 61 6e 64 20 28 61 it.... ((and (a
2920: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
2930: 72 75 6e 22 29 0a 09 09 09 09 28 6c 65 74 20 28 run").....(let (
2940: 28 72 65 72 75 6e 6c 73 74 20 28 73 74 72 69 6e (rerunlst (strin
2950: 67 2d 73 70 6c 69 74 20 28 61 72 67 73 3a 67 65 g-split (args:ge
2960: 74 2d 61 72 67 20 22 2d 72 65 72 75 6e 22 29 20 t-arg "-rerun")
2970: 22 2c 22 29 29 29 20 3b 3b 20 46 41 49 4c 2c 0a ","))) ;; FAIL,.
2980: 09 09 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 .... (member (t
2990: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
29a0: 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 estdat) rerunlst
29b0: 29 29 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 ))).... (set!
29c0: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 09 runflag #t))....
29d0: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c ;; -keepgoing,
29e0: 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 do not rerun FA
29f0: 49 4c 0a 09 09 09 20 20 28 28 61 6e 64 20 28 61 IL.... ((and (a
2a00: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6b 65 rgs:get-arg "-ke
2a10: 65 70 67 6f 69 6e 67 22 29 0a 09 09 09 09 28 6d epgoing").....(m
2a20: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
2a30: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
2a40: 27 28 22 46 41 49 4c 22 29 29 29 0a 09 09 09 20 '("FAIL")))....
2a50: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
2a60: 23 66 29 29 0a 09 09 09 20 20 28 28 61 6e 64 20 #f)).... ((and
2a70: 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 (not (args:get-a
2a80: 72 67 20 22 2d 72 65 72 75 6e 22 29 29 0a 09 09 rg "-rerun"))...
2a90: 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a ..(member (test:
2aa0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
2ab0: 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 6e 2f at) '("FAIL" "n/
2ac0: 61 22 29 29 29 0a 09 09 09 20 20 20 28 73 65 74 a"))).... (set
2ad0: 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 ! runflag #t))..
2ae0: 09 09 20 20 28 65 6c 73 65 20 28 73 65 74 21 20 .. (else (set!
2af0: 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a 09 09 runflag #f)))...
2b00: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 . (debug:print 6
2b10: 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e "RUNNING => run
2b20: 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 flag: " runflag
2b30: 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 73 74 " STATE: " (test
2b40: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
2b50: 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 22 20 at) " STATUS: "
2b60: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
2b70: 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 20 28 testdat)).... (
2b80: 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 if (not runflag)
2b90: 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f .... (if (no
2ba0: 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 t parent-test)..
2bb0: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
2bc0: 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 1 "NOTE: Not st
2bd0: 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 6e 65 arting test " ne
2be0: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 w-test-name " as
2bf0: 20 69 74 20 69 73 20 73 74 61 74 65 20 5c 22 43 it is state \"C
2c00: 4f 4d 50 4c 45 54 45 44 5c 22 20 61 6e 64 20 73 OMPLETED\" and s
2c10: 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a tatus \"" (test:
2c20: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
2c30: 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 66 6f at) "\", use -fo
2c40: 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 rce to override"
2c50: 29 29 0a 09 09 09 20 20 20 20 20 28 6c 65 74 2a )).... (let*
2c60: 20 28 28 67 65 74 2d 70 72 65 72 65 71 73 2d 63 ((get-prereqs-c
2c70: 6d 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 md (lambda ()...
2c80: 09 09 09 09 20 20 20 20 20 20 20 28 64 62 2d 67 .... (db-g
2c90: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
2ca0: 65 74 20 64 62 20 72 75 6e 2d 69 64 20 77 61 69 et db run-id wai
2cb0: 74 6f 6e 29 29 29 20 3b 3b 20 63 68 65 63 6b 20 ton))) ;; check
2cc0: 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e 67 20 2e before running .
2cd0: 2e 2e 2e 0a 09 09 09 09 20 20 20 20 28 6c 61 75 ........ (lau
2ce0: 6e 63 68 2d 63 6d 64 20 20 20 20 20 20 28 6c 61 nch-cmd (la
2cf0: 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 20 mbda ().......
2d00: 20 20 20 20 20 28 6c 61 75 6e 63 68 2d 74 65 73 (launch-tes
2d10: 74 20 64 62 20 72 75 6e 2d 69 64 20 28 61 72 67 t db run-id (arg
2d20: 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn
2d30: 61 6d 65 22 29 20 74 65 73 74 2d 63 6f 6e 66 20 ame") test-conf
2d40: 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e keyvallst test-n
2d50: 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 ame test-path it
2d60: 65 6d 64 61 74 20 61 72 67 73 3a 61 72 67 2d 68 emdat args:arg-h
2d70: 61 73 68 29 29 29 0a 09 09 09 09 20 20 20 20 28 ash)))..... (
2d80: 74 65 73 74 72 75 6e 64 61 74 20 20 20 20 20 20 testrundat
2d90: 28 6c 69 73 74 20 67 65 74 2d 70 72 65 72 65 71 (list get-prereq
2da0: 73 2d 63 6d 64 20 6c 61 75 6e 63 68 2d 63 6d 64 s-cmd launch-cmd
2db0: 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 ))).... (i
2dc0: 66 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d f (or (args:get-
2dd0: 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 arg "-force")...
2de0: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
2df0: 70 72 65 71 73 2d 6e 6f 74 2d 79 65 74 2d 6d 65 preqs-not-yet-me
2e00: 74 20 28 28 63 61 72 20 74 65 73 74 72 75 6e 64 t ((car testrund
2e10: 61 74 29 29 29 29 0a 09 09 09 09 09 20 28 64 65 at))))...... (de
2e20: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 50 72 65 bug:print 2 "Pre
2e30: 71 72 65 71 75 65 73 69 74 65 73 20 66 6f 72 20 qrequesites for
2e40: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 3a 20 22 " test-name ": "
2e50: 20 70 72 65 71 73 2d 6e 6f 74 2d 79 65 74 2d 6d preqs-not-yet-m
2e60: 65 74 29 0a 09 09 09 09 09 20 28 6e 75 6c 6c 3f et)...... (null?
2e70: 20 70 72 65 71 73 2d 6e 6f 74 2d 79 65 74 2d 6d preqs-not-yet-m
2e80: 65 74 29 29 29 20 3b 3b 20 61 72 65 20 74 68 65 et))) ;; are the
2e90: 72 65 20 61 6e 79 20 74 65 73 74 73 20 74 68 61 re any tests tha
2ea0: 74 20 6d 75 73 74 20 62 65 20 72 75 6e 20 62 65 t must be run be
2eb0: 66 6f 72 65 20 74 68 69 73 20 6f 6e 65 2e 2e 2e fore this one...
2ec0: 0a 09 09 09 09 20 20 20 28 69 66 20 28 6e 6f 74 ..... (if (not
2ed0: 20 28 28 63 61 64 72 20 74 65 73 74 72 75 6e 64 ((cadr testrund
2ee0: 61 74 29 29 29 20 3b 3b 20 74 68 69 73 20 69 73 at))) ;; this is
2ef0: 20 74 68 65 20 6c 69 6e 65 20 74 68 61 74 20 6c the line that l
2f00: 61 75 6e 63 68 65 73 20 74 68 65 20 74 65 73 74 aunches the test
2f10: 20 74 6f 20 74 68 65 20 72 65 6d 6f 74 65 20 68 to the remote h
2f20: 6f 73 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 ost..... (
2f30: 62 65 67 69 6e 0a 09 09 09 09 09 20 28 70 72 69 begin...... (pri
2f40: 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 nt "ERROR: Faile
2f50: 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 d to launch the
2f60: 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 73 test. Exiting as
2f70: 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c soon as possibl
2f80: 65 22 29 0a 09 09 09 09 09 20 28 73 65 74 21 20 e")...... (set!
2f90: 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
2fa0: 73 2a 20 31 29 20 3b 3b 20 0a 09 09 09 09 09 20 s* 1) ;; ......
2fb0: 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 (process-signal
2fc0: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
2fd0: 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c -id) signal/kill
2fe0: 29 0a 09 09 09 09 09 20 3b 28 65 78 69 74 20 31 )...... ;(exit 1
2ff0: 29 0a 09 09 09 09 09 20 29 29 0a 09 09 09 09 20 )...... )).....
3000: 20 20 28 69 66 20 28 6e 6f 74 20 28 61 72 67 73 (if (not (args
3010: 3a 67 65 74 2d 61 72 67 20 22 2d 6b 65 65 70 67 :get-arg "-keepg
3020: 6f 69 6e 67 22 29 29 0a 09 09 09 09 20 20 20 20 oing")).....
3030: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
3040: 65 74 21 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 et! *waiting-que
3050: 75 65 2a 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d ue* new-test-nam
3060: 65 20 74 65 73 74 72 75 6e 64 61 74 29 29 29 29 e testrundat))))
3070: 29 29 29 0a 09 09 20 20 20 20 20 20 28 28 4b 49 )))... ((KI
3080: 4c 4c 45 44 29 20 0a 09 09 20 20 20 20 20 20 20 LLED) ...
3090: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
30a0: 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 74 NOTE: " new-test
30b0: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
30c0: 64 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 dy running or wa
30d0: 73 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c s explictly kill
30e0: 65 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 74 ed, use -force t
30f0: 6f 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 0a o launch it.")).
3100: 09 09 20 20 20 20 20 20 28 28 4c 41 55 4e 43 48 .. ((LAUNCH
3110: 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 ED REMOTEHOSTSTA
3120: 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a 09 09 RT RUNNING) ...
3130: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 2d (if (> (-
3140: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3150: 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 s)(+ (db:test-ge
3160: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 t-event_time tes
3170: 74 64 61 74 29 0a 09 09 09 09 09 09 20 20 20 20 tdat).......
3180: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
3190: 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 n_duration testd
31a0: 61 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 31 at))).... 1
31b0: 30 30 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 00) ;; i.e. no u
31c0: 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 pdate for more t
31d0: 68 61 6e 20 31 30 30 20 73 65 63 6f 6e 64 73 0a han 100 seconds.
31e0: 09 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 ... (begin....
31f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3200: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 t 0 "WARNING: Te
3210: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
3220: 20 61 70 70 65 61 72 73 20 74 6f 20 62 65 20 64 appears to be d
3230: 65 61 64 2e 20 46 6f 72 63 69 6e 67 20 69 74 20 ead. Forcing it
3240: 74 6f 20 73 74 61 74 65 20 49 4e 43 4f 4d 50 4c to state INCOMPL
3250: 45 54 45 20 61 6e 64 20 73 74 61 74 75 73 20 53 ETE and status S
3260: 54 55 43 4b 2f 44 45 41 44 22 29 0a 09 09 09 20 TUCK/DEAD")....
3270: 20 20 20 20 28 74 65 73 74 2d 73 65 74 2d 73 74 (test-set-st
3280: 61 74 75 73 21 20 64 62 20 72 75 6e 2d 69 64 20 atus! db run-id
3290: 74 65 73 74 2d 6e 61 6d 65 20 22 49 4e 43 4f 4d test-name "INCOM
32a0: 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 PLETE" "STUCK/DE
32b0: 41 44 22 20 69 74 65 6d 64 61 74 20 22 54 65 73 AD" itemdat "Tes
32c0: 74 20 69 73 20 73 74 75 63 6b 20 6f 72 20 64 65 t is stuck or de
32d0: 61 64 22 20 23 66 29 29 0a 09 09 09 20 20 20 28 ad" #f)).... (
32e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e debug:print 2 "N
32f0: 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 OTE: " test-name
3300: 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 " is already ru
3310: 6e 6e 69 6e 67 22 29 29 29 0a 09 09 20 20 20 20 nning")))...
3320: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 28 64 (else (d
3330: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
3340: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c ROR: Failed to l
3350: 61 75 6e 63 68 20 74 65 73 74 20 22 20 6e 65 77 aunch test " new
3360: 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e -test-name ". Un
3370: 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 recognised state
3380: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
3390: 74 65 20 74 65 73 74 64 61 74 29 29 29 29 29 29 te testdat))))))
33a0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 .. (if (not
33b0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
33c0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
33d0: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 )(cdr tal)))))))
33e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
33f0: 2d 77 61 69 74 69 6e 67 2d 74 65 73 74 73 20 64 -waiting-tests d
3400: 62 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 74 b). (let ((numt
3410: 72 69 65 73 20 20 20 20 20 20 20 20 20 20 20 30 ries 0
3420: 29 0a 09 28 6c 61 73 74 2d 74 72 79 2d 74 69 6d )..(last-try-tim
3430: 65 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d e (current-
3440: 73 65 63 6f 6e 64 73 29 29 0a 09 28 74 69 6d 65 seconds))..(time
3450: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 s (
3460: 6c 69 73 74 20 31 29 29 29 20 3b 3b 20 6d 69 6e list 1))) ;; min
3470: 75 74 65 73 20 74 6f 20 77 61 69 74 20 62 65 66 utes to wait bef
3480: 6f 72 65 20 74 72 79 69 6e 67 20 61 67 61 69 6e ore trying again
3490: 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 72 75 6e to kick off run
34a0: 73 0a 20 20 20 20 3b 3b 20 42 55 47 20 74 68 69 s. ;; BUG thi
34b0: 73 20 68 61 63 6b 20 6f 66 20 62 72 75 74 65 20 s hack of brute
34c0: 66 6f 72 63 65 20 72 65 74 72 79 69 6e 67 20 77 force retrying w
34d0: 6f 72 6b 73 20 71 75 69 74 65 20 77 65 6c 6c 20 orks quite well
34e0: 66 6f 72 20 6d 61 6e 79 20 63 61 73 65 73 20 62 for many cases b
34f0: 75 74 20 0a 20 20 20 20 3b 3b 20 20 20 20 20 77 ut . ;; w
3500: 68 61 74 20 69 73 20 6e 65 65 64 65 64 20 69 73 hat is needed is
3510: 20 74 6f 20 63 68 65 63 6b 20 74 68 65 20 64 62 to check the db
3520: 20 66 6f 72 20 74 65 73 74 73 20 74 68 61 74 20 for tests that
3530: 68 61 76 65 20 66 61 69 6c 65 64 20 6c 65 73 73 have failed less
3540: 20 74 68 61 6e 0a 20 20 20 20 3b 3b 20 20 20 20 than. ;;
3550: 20 4e 20 74 69 6d 65 73 20 6f 72 20 6e 65 76 65 N times or neve
3560: 72 20 62 65 65 6e 20 73 74 61 72 74 65 64 20 61 r been started a
3570: 6e 64 20 6b 69 63 6b 20 74 68 65 6d 20 6f 66 66 nd kick them off
3580: 20 61 67 61 69 6e 0a 20 20 20 20 28 6c 65 74 20 again. (let
3590: 6c 6f 6f 70 20 28 28 77 61 69 74 69 6e 67 2d 74 loop ((waiting-t
35a0: 65 73 74 2d 6e 61 6d 65 73 20 28 68 61 73 68 2d est-names (hash-
35b0: 74 61 62 6c 65 2d 6b 65 79 73 20 2a 77 61 69 74 table-keys *wait
35c0: 69 6e 67 2d 71 75 65 75 65 2a 29 29 29 0a 20 20 ing-queue*))).
35d0: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
35e0: 20 28 28 6e 6f 74 20 28 72 75 6e 73 3a 63 61 6e ((not (runs:can
35f0: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 -run-more-tests
3600: 64 62 29 29 0a 09 28 74 68 72 65 61 64 2d 73 6c db))..(thread-sl
3610: 65 65 70 21 20 32 29 0a 09 28 6c 6f 6f 70 20 77 eep! 2)..(loop w
3620: 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d 65 aiting-test-name
3630: 73 29 29 0a 20 20 20 20 20 20 20 28 28 6e 75 6c s)). ((nul
3640: 6c 3f 20 77 61 69 74 69 6e 67 2d 74 65 73 74 2d l? waiting-test-
3650: 6e 61 6d 65 73 29 0a 09 28 64 65 62 75 67 3a 70 names)..(debug:p
3660: 72 69 6e 74 20 31 20 22 41 6c 6c 20 74 65 73 74 rint 1 "All test
3670: 73 20 6c 61 75 6e 63 68 65 64 22 29 29 0a 20 20 s launched")).
3680: 20 20 20 20 20 28 65 6c 73 65 0a 09 28 73 65 74 (else..(set
3690: 21 20 6e 75 6d 74 72 69 65 73 20 28 2b 20 6e 75 ! numtries (+ nu
36a0: 6d 74 72 69 65 73 20 31 29 29 0a 09 28 66 6f 72 mtries 1))..(for
36b0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
36c0: 65 73 74 6e 61 6d 65 29 0a 09 09 20 20 20 20 28 estname)... (
36d0: 69 66 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e if (runs:can-run
36e0: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 0a -more-tests db).
36f0: 09 09 09 28 6c 65 74 2a 20 28 28 74 65 73 74 64 ...(let* ((testd
3700: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
3710: 65 66 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 ef *waiting-queu
3720: 65 2a 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 09 e* testname))...
3730: 09 20 20 20 20 20 20 20 28 70 72 65 72 65 71 73 . (prereqs
3740: 20 28 28 63 61 72 20 74 65 73 74 64 61 74 29 29 ((car testdat))
3750: 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c 64 62 ).... (ldb
3760: 20 20 20 20 20 28 69 66 20 64 62 20 64 62 20 28 (if db db (
3770: 6f 70 65 6e 2d 64 62 29 29 29 29 0a 09 09 09 20 open-db))))....
3780: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
3790: 22 70 72 65 72 65 71 73 20 72 65 6d 61 69 6e 69 "prereqs remaini
37a0: 6e 67 3a 20 22 20 70 72 65 72 65 71 73 29 0a 09 ng: " prereqs)..
37b0: 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 .. (if (null? p
37c0: 72 65 72 65 71 73 29 0a 09 09 09 20 20 20 20 20 rereqs)....
37d0: 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 (begin.....(deb
37e0: 75 67 3a 70 72 69 6e 74 20 32 20 22 50 72 65 72 ug:print 2 "Prer
37f0: 65 71 75 69 73 69 74 65 73 20 6d 65 74 2c 20 6c equisites met, l
3800: 61 75 6e 63 68 69 6e 67 20 22 20 74 65 73 74 6e aunching " testn
3810: 61 6d 65 29 0a 09 09 09 09 28 28 63 61 64 72 20 ame).....((cadr
3820: 74 65 73 74 64 61 74 29 29 0a 09 09 09 09 28 68 testdat)).....(h
3830: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
3840: 21 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 65 ! *waiting-queue
3850: 2a 20 74 65 73 74 6e 61 6d 65 29 29 29 0a 09 09 * testname)))...
3860: 09 20 20 28 69 66 20 28 6e 6f 74 20 64 62 29 0a . (if (not db).
3870: 09 09 09 20 20 20 20 20 20 28 73 71 6c 69 74 65 ... (sqlite
3880: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 6c 64 62 29 3:finalize! ldb)
3890: 29 29 29 29 0a 09 09 20 20 77 61 69 74 69 6e 67 ))))... waiting
38a0: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 0a 09 3b 3b -test-names)..;;
38b0: 20 28 73 6c 65 65 70 20 31 30 29 20 3b 3b 20 6e (sleep 10) ;; n
38c0: 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 73 68 69 o point in rushi
38d0: 6e 67 20 74 68 69 6e 67 73 20 61 74 20 74 68 69 ng things at thi
38e0: 73 20 73 74 61 67 65 3f 0a 09 28 6c 6f 6f 70 20 s stage?..(loop
38f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
3900: 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 65 2a *waiting-queue*
3910: 29 29 29 29 29 29 29 0a ))))))).