Artifact 5b3ba61f62c5e74b874e2e4cb8f459328823d0f4:
- File run-tests-queue-classic.scm — part of check-in [dec6d535be] at 2013-05-06 14:28:02 on branch v1.54 — Fixed running dependent tests problem (user: mrwellan size: 16840)
0000: 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 .;; test-records 0010: 20 69 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 is a hash table 0020: 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 testname:item_p 0030: 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 ath => vector < 0040: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e testname testcon 0050: 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f fig waitons prio 0060: 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 rity items-info 0070: 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 ... >.(define (r 0080: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu 0090: 65 75 65 2d 63 6c 61 73 73 69 63 20 72 75 6e 2d eue-classic run- 00a0: 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d id runname test- 00b0: 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 6c 73 records keyvalls 00c0: 74 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 t flags test-pat 00d0: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test 00e0: 73 29 0a 20 20 20 20 3b 3b 20 41 74 20 74 68 69 s). ;; At thi 00f0: 73 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 73 74 s point the list 0100: 20 6f 66 20 70 61 72 65 6e 74 20 74 65 73 74 73 of parent tests 0110: 20 69 73 20 65 78 70 61 6e 64 65 64 20 0a 20 20 is expanded . 0120: 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 ;; NB// Should 0130: 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 68 65 expand items he 0140: 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 65 re and then inse 0150: 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 6e 20 rt into the run 0160: 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 67 3a queue.. (debug: 0170: 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d 72 65 print 5 "test-re 0180: 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d 72 65 cords: " test-re 0190: 63 6f 72 64 73 20 22 2c 20 6b 65 79 76 61 6c 6c cords ", keyvall 01a0: 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 st: " keyvallst 01b0: 22 20 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 " flags: " (hash 01c0: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c -table->alist fl 01d0: 61 67 73 29 29 0a 20 20 28 6c 65 74 20 28 28 72 ags)). (let ((r 01e0: 75 6e 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 un-info 01f0: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote 0200: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e 2d -run db:get-run- 0210: 69 6e 66 6f 20 23 66 20 72 75 6e 2d 69 64 29 29 info #f run-id)) 0220: 0a 09 28 6b 65 79 2d 76 61 6c 73 20 20 20 20 20 ..(key-vals 0230: 20 20 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 (cdb:re 0240: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get- 0250: 6b 65 79 2d 76 61 6c 73 20 23 66 20 72 75 6e 2d key-vals #f run- 0260: 69 64 29 29 0a 09 28 73 6f 72 74 65 64 2d 74 65 id))..(sorted-te 0270: 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 28 74 65 st-names (te 0280: 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f sts:sort-by-prio 0290: 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 rity-and-waiton 02a0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records)).. 02b0: 28 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 20 (test-registry 02c0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has 02d0: 68 2d 74 61 62 6c 65 29 29 0a 09 28 72 65 67 69 h-table))..(regi 02e0: 73 74 72 79 2d 6d 75 74 65 78 20 20 20 20 20 20 stry-mutex 02f0: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)). 0300: 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 20 20 20 .(num-retries 0310: 20 20 20 20 20 20 20 20 30 29 0a 09 28 6d 61 78 0)..(max 0320: 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 20 20 -retries 0330: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku 0340: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s 0350: 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 69 65 etup" "maxretrie 0360: 73 22 29 29 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 s"))..(max-concu 0370: 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 28 6c 65 rrent-jobs (le 0380: 74 20 28 28 6d 63 6a 20 28 63 6f 6e 66 69 67 2d t ((mcj (config- 0390: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda 03a0: 74 2a 20 22 73 65 74 75 70 22 20 20 20 20 20 22 t* "setup" " 03b0: 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a max_concurrent_j 03c0: 6f 62 73 22 29 29 29 0a 09 09 09 09 20 28 69 66 obs")))..... (if 03d0: 20 28 61 6e 64 20 6d 63 6a 20 28 73 74 72 69 6e (and mcj (strin 03e0: 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 29 0a g->number mcj)). 03f0: 09 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 .... (string 0400: 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 0a 09 09 ->number mcj)... 0410: 09 09 20 20 20 20 20 31 29 29 29 29 0a 20 20 20 .. 1)))). 0420: 20 28 73 65 74 21 20 6d 61 78 2d 72 65 74 72 69 (set! max-retri 0430: 65 73 20 28 69 66 20 28 61 6e 64 20 6d 61 78 2d es (if (and max- 0440: 72 65 74 72 69 65 73 20 28 73 74 72 69 6e 67 2d retries (string- 0450: 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 >number max-retr 0460: 69 65 73 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 ies))(string->nu 0470: 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 mber max-retries 0480: 29 20 31 30 30 29 29 0a 20 20 20 20 28 69 66 20 ) 100)). (if 0490: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 73 6f 72 74 (not (null? sort 04a0: 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ed-test-names)). 04b0: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 .(let loop ((hed 04c0: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 73 6f (car so 04d0: 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 rted-test-names) 04e0: 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 20 20 )... (tal 04f0: 20 20 20 20 28 63 64 72 20 73 6f 72 74 65 64 2d (cdr sorted- 0500: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))... 0510: 20 20 28 72 65 72 75 6e 73 20 20 20 20 20 20 27 (reruns ' 0520: 28 29 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 ())).. (if (not 0530: 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 (null? reruns)) 0540: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf 0550: 6f 20 34 20 22 72 65 72 75 6e 73 3d 22 20 72 65 o 4 "reruns=" re 0560: 72 75 6e 73 29 29 0a 09 20 20 3b 3b 20 28 70 72 runs)).. ;; (pr 0570: 69 6e 74 20 22 54 6f 70 20 6f 66 20 6c 6f 6f 70 int "Top of loop 0580: 2c 20 68 65 64 3d 22 20 68 65 64 20 22 2c 20 74 , hed=" hed ", t 0590: 61 6c 3d 22 20 74 61 6c 20 22 20 2c 72 65 72 75 al=" tal " ,reru 05a0: 6e 73 3d 22 20 72 65 72 75 6e 73 29 0a 09 20 20 ns=" reruns).. 05b0: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 63 (let* ((test-rec 05c0: 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ord (hash-table- 05d0: 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records 05e0: 20 68 65 64 29 29 0a 09 09 20 28 74 65 73 74 2d hed))... (test- 05f0: 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 65 name (tests:te 0600: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test 0610: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record 0620: 29 29 0a 09 09 20 28 74 63 6f 6e 66 69 67 20 20 ))... (tconfig 0630: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu 0640: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf 0650: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record)) 0660: 0a 09 09 20 28 74 65 73 74 6d 6f 64 65 20 20 20 ... (testmode 0670: 20 28 6c 65 74 20 28 28 6d 20 28 63 6f 6e 66 69 (let ((m (confi 0680: 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 g-lookup tconfig 0690: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements" 06a0: 22 6d 6f 64 65 22 29 29 29 0a 09 09 09 09 28 69 "mode"))).....(i 06b0: 66 20 6d 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d f m (string->sym 06c0: 62 6f 6c 20 6d 29 20 27 6e 6f 72 6d 61 6c 29 29 bol m) 'normal)) 06d0: 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 20 20 )... (waitons 06e0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque 06f0: 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 ue-get-waitons 0700: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a test-record)). 0710: 09 09 20 28 70 72 69 6f 72 69 74 79 20 20 20 20 .. (priority 0720: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue 0730: 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 20 20 -get-priority 0740: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 test-record))... 0750: 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 28 74 (itemdat (t 0760: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g 0770: 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 et-itemdat te 0780: 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 st-record)) ;; i 0790: 74 65 6d 64 61 74 20 63 61 6e 20 62 65 20 61 20 temdat can be a 07a0: 73 74 72 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 string, list or 07b0: 23 66 0a 09 09 20 28 69 74 65 6d 73 20 20 20 20 #f... (items 07c0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu 07d0: 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 20 20 20 eue-get-items 07e0: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record)) 07f0: 0a 09 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 ... (item-path 0800: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat 0810: 68 20 69 74 65 6d 64 61 74 29 29 0a 09 09 20 28 h itemdat))... ( 0820: 6e 65 77 74 61 6c 20 20 20 20 20 20 28 61 70 70 newtal (app 0830: 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 20 68 65 end tal (list he 0840: 64 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 d)))).. .. 0850: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 0a (debug:print 6. 0860: 09 09 09 20 22 74 65 73 74 2d 6e 61 6d 65 3a 20 ... "test-name: 0870: 22 20 74 65 73 74 2d 6e 61 6d 65 0a 09 09 09 20 " test-name.... 0880: 22 5c 6e 20 20 68 65 64 3a 20 20 20 20 20 20 20 "\n hed: 0890: 20 20 22 20 68 65 64 0a 09 09 09 20 22 5c 6e 20 " hed.... "\n 08a0: 20 69 74 65 6d 64 61 74 3a 20 20 20 20 20 22 20 itemdat: " 08b0: 69 74 65 6d 64 61 74 0a 09 09 09 20 22 5c 6e 20 itemdat.... "\n 08c0: 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 22 20 items: " 08d0: 69 74 65 6d 73 0a 09 09 09 20 22 5c 6e 20 20 69 items.... "\n i 08e0: 74 65 6d 2d 70 61 74 68 3a 20 20 20 22 20 69 74 tem-path: " it 08f0: 65 6d 2d 70 61 74 68 0a 09 09 09 20 22 5c 6e 20 em-path.... "\n 0900: 20 77 61 69 74 6f 6e 73 3a 20 20 20 20 20 22 20 waitons: " 0910: 77 61 69 74 6f 6e 73 0a 09 09 09 20 22 5c 6e 20 waitons.... "\n 0920: 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 22 20 num-retries: " 0930: 6e 75 6d 2d 72 65 74 72 69 65 73 0a 09 09 09 20 num-retries.... 0940: 22 5c 6e 20 20 74 61 6c 3a 20 20 20 20 20 20 20 "\n tal: 0950: 20 20 22 20 74 61 6c 0a 09 09 09 20 22 5c 6e 20 " tal.... "\n 0960: 20 72 65 72 75 6e 73 3a 20 20 20 20 20 20 22 20 reruns: " 0970: 72 65 72 75 6e 73 29 0a 0a 09 20 20 20 20 3b 3b reruns)... ;; 0980: 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 check for hed i 0990: 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 n waitons => thi 09a0: 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 s would be circu 09b0: 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 lar, remove it a 09c0: 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 20 20 20 nd issue an.. 09d0: 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 20 20 28 ;; error.. ( 09e0: 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 74 2d if (member test- 09f0: 6e 61 6d 65 20 77 61 69 74 6f 6e 73 29 0a 09 09 name waitons)... 0a00: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu 0a10: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR 0a20: 3a 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 : test " test-na 0a30: 6d 65 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 me " has listed 0a40: 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 itself as a wait 0a50: 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 on, please corre 0a60: 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 28 ct this!")... ( 0a70: 73 65 74 21 20 77 61 69 74 6f 6e 20 28 66 69 6c set! waiton (fil 0a80: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 ter (lambda (x)( 0a90: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 not (equal? x he 0aa0: 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 d))) waitons)))) 0ab0: 0a 0a 09 20 20 20 20 28 63 6f 6e 64 20 3b 3b 20 ... (cond ;; 0ac0: 4f 55 54 45 52 20 43 4f 4e 44 0a 09 20 20 20 20 OUTER COND.. 0ad0: 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 20 3b 3b ((not items) ;; 0ae0: 20 77 68 65 6e 20 66 61 6c 73 65 20 74 68 65 20 when false the 0af0: 74 65 73 74 20 69 73 20 6f 6b 20 74 6f 20 62 65 test is ok to be 0b00: 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 6c handed off to l 0b10: 61 75 6e 63 68 20 28 62 75 74 20 6e 6f 74 20 62 aunch (but not b 0b20: 65 66 6f 72 65 29 0a 09 20 20 20 20 20 20 28 69 efore).. (i 0b30: 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 74 65 73 f (and (not (tes 0b40: 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 ts:match test-pa 0b50: 74 74 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 tts (tests:testq 0b60: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam 0b70: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 69 e test-record) i 0b80: 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 72 65 tem-path require 0b90: 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 d: required-test 0ba0: 73 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 20 s)).. 0bb0: 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (not (null? 0bc0: 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 20 20 tal))).. 0bd0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new 0be0: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal) 0bf0: 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 reruns)).. 0c00: 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 6c 69 6d (let* ((run-lim 0c10: 69 74 73 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 its-info 0c20: 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d (runs:can-run-m 0c30: 6f 72 65 2d 74 65 73 74 73 20 74 65 73 74 2d 72 ore-tests test-r 0c40: 65 63 6f 72 64 20 6d 61 78 2d 63 6f 6e 63 75 72 ecord max-concur 0c50: 72 65 6e 74 2d 6a 6f 62 73 29 29 20 3b 3b 20 6c rent-jobs)) ;; l 0c60: 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 ook at the test 0c70: 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 jobgroup and tot 0c80: 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 09 jobs running... 0c90: 20 20 20 20 20 28 68 61 76 65 2d 72 65 73 6f 75 (have-resou 0ca0: 72 63 65 73 20 20 20 20 20 20 20 20 20 20 28 63 rces (c 0cb0: 61 72 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ar run-limits-in 0cc0: 66 6f 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d fo))... (num 0cd0: 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 -running 0ce0: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 (list-ref r 0cf0: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 31 un-limits-info 1 0d00: 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d 2d 72 ))... (num-r 0d10: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro 0d20: 75 70 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e up (list-ref run 0d30: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 29 29 -limits-info 2)) 0d40: 0a 09 09 20 20 20 20 20 28 6d 61 78 2d 63 6f 6e ... (max-con 0d50: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 current-jobs 0d60: 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c (list-ref run-l 0d70: 69 6d 69 74 73 2d 69 6e 66 6f 20 33 29 29 0a 09 imits-info 3)).. 0d80: 09 20 20 20 20 20 28 6a 6f 62 2d 67 72 6f 75 70 . (job-group 0d90: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit ( 0da0: 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d list-ref run-lim 0db0: 69 74 73 2d 69 6e 66 6f 20 34 29 29 0a 09 09 20 its-info 4))... 0dc0: 20 20 20 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 (prereqs-not 0dd0: 2d 6d 65 74 20 20 20 20 20 20 20 20 20 28 64 62 -met (db 0de0: 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 :get-prereqs-not 0df0: 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 -met run-id wait 0e00: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f ons item-path mo 0e10: 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 de: testmode)).. 0e20: 09 20 20 20 20 20 28 66 61 69 6c 73 20 20 20 20 . (fails 0e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 0e40: 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 runs:calc-fails 0e50: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met) 0e60: 29 0a 09 09 20 20 20 20 20 28 6e 6f 6e 2d 63 6f )... (non-co 0e70: 6d 70 6c 65 74 65 64 20 20 20 20 20 20 20 20 20 mpleted 0e80: 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 (runs:calc-not 0e90: 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 -completed prere 0ea0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 qs-not-met)))... 0eb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf 0ec0: 6f 20 38 20 22 68 61 76 65 2d 72 65 73 6f 75 72 o 8 "have-resour 0ed0: 63 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f ces: " have-reso 0ee0: 75 72 63 65 73 20 22 20 70 72 65 72 65 71 73 2d urces " prereqs- 0ef0: 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 09 09 20 not-met: " .... 0f00: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte 0f10: 72 73 70 65 72 73 65 20 0a 09 09 09 20 20 20 20 rsperse .... 0f20: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda ( 0f30: 74 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 t)..... (if 0f40: 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 (vector? t)..... 0f50: 09 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 . (conc (db:test 0f60: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/ 0f70: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s 0f80: 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 09 20 tatus t))...... 0f90: 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a (conc " WARNING: 0fa0: 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 t is not a vect 0fb0: 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 09 20 or=" t )))..... 0fc0: 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 prereqs-not-me 0fd0: 74 29 20 22 2c 20 22 29 20 22 20 66 61 69 6c 73 t) ", ") " fails 0fe0: 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 28 64 65 : " fails)...(de 0ff0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4 1000: 20 22 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 "hed=" hed "\n 1010: 20 74 65 73 74 2d 72 65 63 6f 72 64 3d 22 20 74 test-record=" t 1020: 65 73 74 2d 72 65 63 6f 72 64 20 22 5c 6e 20 20 est-record "\n 1030: 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 test-name: " tes 1040: 74 2d 6e 61 6d 65 20 22 5c 6e 20 20 69 74 65 6d t-name "\n item 1050: 2d 70 61 74 68 3a 20 22 20 69 74 65 6d 2d 70 61 -path: " item-pa 1060: 74 68 20 22 5c 6e 20 20 74 65 73 74 2d 70 61 74 th "\n test-pat 1070: 74 73 3a 20 22 20 74 65 73 74 2d 70 61 74 74 73 ts: " test-patts 1080: 29 0a 0a 09 09 3b 3b 20 44 6f 6e 27 74 20 6b 6e )....;; Don't kn 1090: 6f 77 20 61 74 20 74 68 69 73 20 74 69 6d 65 20 ow at this time 10a0: 69 66 20 74 68 65 20 74 65 73 74 20 68 61 76 65 if the test have 10b0: 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 64 20 61 been launched a 10c0: 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 6e 20 74 t some time in t 10d0: 68 65 20 70 61 73 74 0a 09 09 3b 3b 20 69 2e 65 he past...;; i.e 10e0: 2e 20 69 73 20 74 68 69 73 20 61 20 72 65 2d 6c . is this a re-l 10f0: 61 75 6e 63 68 3f 0a 09 09 28 64 65 62 75 67 3a aunch?...(debug: 1100: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 print-info 4 "ru 1110: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 3d 20 n-limits-info = 1120: 22 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 " run-limits-inf 1130: 6f 29 0a 09 09 28 63 6f 6e 64 20 3b 3b 20 49 4e o)...(cond ;; IN 1140: 4e 45 52 20 43 4f 4e 44 20 23 31 20 66 6f 72 20 NER COND #1 for 1150: 61 20 6c 61 75 6e 63 68 61 62 6c 65 20 74 65 73 a launchable tes 1160: 74 0a 09 09 20 3b 3b 20 43 68 65 63 6b 20 69 74 t... ;; Check it 1170: 65 6d 20 70 61 74 68 20 61 67 61 69 6e 73 74 20 em path against 1180: 69 74 65 6d 2d 70 61 74 74 73 0a 09 09 20 28 28 item-patts... (( 1190: 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 not (tests:match 11a0: 20 74 65 73 74 2d 70 61 74 74 73 20 28 74 65 73 test-patts (tes 11b0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get 11c0: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r 11d0: 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 68 ecord) item-path 11e0: 20 72 65 71 75 69 72 65 64 3a 20 72 65 71 75 69 required: requi 11f0: 72 65 64 2d 74 65 73 74 73 29 29 20 3b 3b 20 54 red-tests)) ;; T 1200: 68 69 73 20 74 65 73 74 2f 69 74 65 6d 70 61 74 his test/itempat 1210: 68 20 69 73 20 6e 6f 74 20 74 6f 20 62 65 20 72 h is not to be r 1220: 75 6e 0a 09 09 20 20 3b 3b 20 65 6c 73 65 20 74 un... ;; else t 1230: 68 65 20 72 75 6e 20 69 73 20 73 74 75 63 6b 2c he run is stuck, 1240: 20 74 65 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 temporarily or 1250: 70 65 72 6d 61 6e 65 6e 74 6c 79 0a 09 09 20 20 permanently... 1260: 3b 3b 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 ;; but should ch 1270: 65 63 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 eck if it is due 1280: 20 74 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f to lack of reso 1290: 75 72 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 urces vs. prereq 12a0: 75 69 73 69 74 65 73 0a 09 09 20 20 28 64 65 62 uisites... (deb 12b0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1 12c0: 22 53 6b 69 70 70 69 6e 67 20 22 20 28 74 65 73 "Skipping " (tes 12d0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get 12e0: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r 12f0: 65 63 6f 72 64 29 20 22 20 22 20 69 74 65 6d 2d ecord) " " item- 1300: 70 61 74 68 20 22 20 61 73 20 69 74 20 64 6f 65 path " as it doe 1310: 73 6e 27 74 20 6d 61 74 63 68 20 22 20 74 65 73 sn't match " tes 1320: 74 2d 70 61 74 74 73 29 0a 09 09 20 20 3b 3b 20 t-patts)... ;; 1330: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a (thread-sleep! * 1340: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 global-delta*).. 1350: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c . (if (not (nul 1360: 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 l? tal))... 1370: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal) 1380: 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 6e 73 (cdr tal) reruns 1390: 29 29 29 0a 09 09 20 3b 3b 20 52 65 67 69 73 74 )))... ;; Regist 13a0: 72 79 20 68 61 73 20 62 65 65 6e 20 73 74 61 72 ry has been star 13b0: 74 65 64 20 66 6f 72 20 74 68 69 73 20 74 65 73 ted for this tes 13c0: 74 20 62 75 74 20 68 61 73 20 6e 6f 74 20 79 65 t but has not ye 13d0: 74 20 63 6f 6d 70 6c 65 74 65 64 0a 09 09 20 3b t completed... ; 13e0: 3b 20 74 68 69 73 20 73 68 6f 75 6c 64 20 62 65 ; this should be 13f0: 20 72 61 72 65 2c 20 74 68 65 20 63 61 73 65 20 rare, the case 1400: 77 68 65 72 65 20 74 68 65 72 65 20 61 72 65 20 where there are 1410: 6f 6e 6c 79 20 61 20 63 6f 75 70 6c 65 20 6f 66 only a couple of 1420: 20 74 65 73 74 73 20 61 6e 64 20 74 68 65 20 64 tests and the d 1430: 62 20 69 73 20 73 6c 6f 77 0a 09 09 20 3b 3b 20 b is slow... ;; 1440: 64 65 6c 61 79 20 61 20 73 68 6f 72 74 20 77 68 delay a short wh 1450: 69 6c 65 20 61 6e 64 20 63 6f 6e 74 69 6e 75 65 ile and continue 1460: 0a 09 09 20 3b 3b 20 28 28 65 71 3f 20 28 68 61 ... ;; ((eq? (ha 1470: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def 1480: 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 ault test-regist 1490: 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 ry (runs:make-fu 14a0: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ll-test-name tes 14b0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path 14c0: 29 20 23 66 29 20 27 73 74 61 72 74 29 0a 09 09 ) #f) 'start)... 14d0: 20 3b 3b 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ;; (thread-sle 14e0: 65 70 21 20 30 2e 30 31 29 0a 09 09 20 3b 3b 20 ep! 0.01)... ;; 14f0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt 1500: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal) 1510: 72 65 72 75 6e 73 29 29 0a 09 09 20 3b 3b 20 63 reruns))... ;; c 1520: 6f 75 6e 74 20 6e 75 6d 62 65 72 20 6f 66 20 27 ount number of ' 1530: 64 6f 6e 65 2c 20 69 66 20 6d 6f 72 65 20 74 68 done, if more th 1540: 61 6e 20 31 30 30 20 74 68 65 6e 20 73 6b 69 70 an 100 then skip 1550: 20 6f 6e 20 74 68 72 6f 75 67 68 2e 0a 09 09 20 on through.... 1560: 28 3b 3b 20 28 61 6e 64 20 28 3c 20 28 6c 65 6e (;; (and (< (len 1570: 67 74 68 20 28 66 69 6c 74 65 72 20 28 6c 61 6d gth (filter (lam 1580: 62 64 61 20 28 78 29 28 65 71 3f 20 78 20 27 64 bda (x)(eq? x 'd 1590: 6f 6e 65 29 29 28 68 61 73 68 2d 74 61 62 6c 65 one))(hash-table 15a0: 2d 76 61 6c 75 65 73 20 74 65 73 74 2d 72 65 67 -values test-reg 15b0: 69 73 74 72 79 29 29 29 20 31 30 30 29 20 3b 3b istry))) 100) ;; 15c0: 20 77 68 79 20 67 65 74 20 6d 6f 72 65 20 74 68 why get more th 15d0: 61 6e 20 32 30 30 20 61 68 65 61 64 3f 0a 09 09 an 200 ahead?... 15e0: 20 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 (not (hash-tab 15f0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t 1600: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 est-registry (ru 1610: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes 1620: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name 1630: 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 29 item-path) #f)) 1640: 20 3b 3b 20 29 20 3b 3b 20 74 6f 6f 20 6d 61 6e ;; ) ;; too man 1650: 79 20 63 68 61 6e 67 65 73 20 72 65 71 75 69 72 y changes requir 1660: 65 64 2e 20 49 6d 70 6c 65 6d 65 6e 74 20 6c 61 ed. Implement la 1670: 74 65 72 2e 0a 09 09 20 20 28 64 65 62 75 67 3a ter.... (debug: 1680: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 50 72 print-info 4 "Pr 1690: 65 2d 72 65 67 69 73 74 65 72 69 6e 67 20 74 65 e-registering te 16a0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name " 16b0: 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 74 /" item-path " t 16c0: 6f 20 63 72 65 61 74 65 20 70 6c 61 63 65 68 6f o create placeho 16d0: 6c 64 65 72 22 20 29 0a 09 09 20 20 3b 3b 20 4e lder" )... ;; N 16e0: 45 45 44 20 54 4f 20 54 48 52 45 41 44 49 46 59 EED TO THREADIFY 16f0: 20 54 48 49 53 0a 09 09 20 20 28 6c 65 74 20 28 THIS... (let ( 1700: 28 74 68 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (th (make-thread 1710: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()... 1720: 20 20 20 20 20 20 09 09 20 20 20 28 6d 75 74 65 .. (mute 1730: 78 2d 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 79 x-lock! registry 1740: 2d 6d 75 74 65 78 29 0a 09 09 20 20 20 20 20 20 -mutex)... 1750: 20 20 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab 1760: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg 1770: 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 istry (runs:make 1780: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name 1790: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p 17a0: 61 74 68 29 20 27 73 74 61 72 74 29 0a 09 09 20 ath) 'start)... 17b0: 20 20 20 20 20 20 20 09 09 20 20 20 28 6d 75 74 .. (mut 17c0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 73 ex-unlock! regis 17d0: 74 72 79 2d 6d 75 74 65 78 29 0a 09 09 09 09 09 try-mutex)...... 17e0: 20 20 20 3b 3b 20 49 66 20 68 61 76 65 6e 27 74 ;; If haven't 17f0: 20 64 6f 6e 65 20 69 74 20 62 65 66 6f 72 65 20 done it before 1800: 72 65 67 69 73 74 65 72 20 61 20 74 6f 70 20 6c register a top l 1810: 65 76 65 6c 20 74 65 73 74 20 69 66 20 74 68 69 evel test if thi 1820: 73 20 69 73 20 61 6e 20 69 74 65 6d 69 7a 65 64 s is an itemized 1830: 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 28 69 test...... (i 1840: 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 68 61 73 f (not (eq? (has 1850: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa 1860: 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 ult test-registr 1870: 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c y (runs:make-ful 1880: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test 1890: 2d 6e 61 6d 65 20 22 22 29 20 23 66 29 20 27 64 -name "") #f) 'd 18a0: 6f 6e 65 29 29 0a 09 09 09 09 09 20 20 20 20 20 one))...... 18b0: 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 (cdb:tests-reg 18c0: 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 ister-test *runr 18d0: 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 emote* run-id te 18e0: 73 74 2d 6e 61 6d 65 20 22 22 29 29 0a 09 09 09 st-name "")).... 18f0: 09 09 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d .. (cdb:tests- 1900: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 register-test *r 1910: 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 unremote* run-id 1920: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item- 1930: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 20 path)... 1940: 09 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b .. (mutex-lock 1950: 21 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 ! registry-mutex 1960: 29 0a 09 09 09 09 09 20 20 20 28 68 61 73 68 2d )...... (hash- 1970: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test- 1980: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m 1990: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na 19a0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite 19b0: 6d 2d 70 61 74 68 29 20 27 64 6f 6e 65 29 0a 09 m-path) 'done).. 19c0: 09 20 20 20 20 20 20 20 20 09 09 20 20 20 28 6d . .. (m 19d0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 utex-unlock! reg 19e0: 69 73 74 72 79 2d 6d 75 74 65 78 29 29 0a 09 09 istry-mutex))... 19f0: 20 20 20 20 20 20 20 20 09 09 20 28 63 6f 6e 63 .. (conc 1a00: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i 1a10: 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 09 20 tem-path))))... 1a20: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start 1a30: 21 20 74 68 29 29 0a 09 09 20 20 3b 3b 20 54 52 ! th))... ;; TR 1a40: 59 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 Y (thread-sleep! 1a50: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*) 1a60: 0a 09 09 20 20 28 72 75 6e 73 3a 73 68 72 69 6e ... (runs:shrin 1a70: 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 k-can-run-more-t 1a80: 65 73 74 73 2d 63 6f 75 6e 74 29 20 20 20 3b 3b ests-count) ;; 1a90: 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 20 28 DELAY TWEAKER ( 1aa0: 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 09 still needed?).. 1ab0: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 . (loop (car ne 1ac0: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal 1ad0: 29 20 72 65 72 75 6e 73 29 29 0a 09 09 20 3b 3b ) reruns))... ;; 1ae0: 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 2a At this point * 1af0: 61 6c 6c 2a 20 74 65 73 74 20 72 65 67 69 73 74 all* test regist 1b00: 72 61 74 69 6f 6e 73 20 6d 75 73 74 20 62 65 20 rations must be 1b10: 63 6f 6d 70 6c 65 74 65 64 2e 0a 09 09 20 28 28 completed.... (( 1b20: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 not (null? (filt 1b30: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 65 er (lambda (x)(e 1b40: 71 3f 20 27 73 74 61 72 74 20 78 29 29 28 68 61 q? 'start x))(ha 1b50: 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 sh-table-values 1b60: 74 65 73 74 2d 72 65 67 69 73 74 72 79 29 29 29 test-registry))) 1b70: 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 )... (debug:pri 1b80: 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 74 69 nt-info 0 "Waiti 1b90: 6e 67 20 6f 6e 20 74 65 73 74 20 72 65 67 69 73 ng on test regis 1ba0: 74 72 61 74 69 6f 6e 73 3a 20 22 20 28 73 74 72 trations: " (str 1bb0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse 1bc0: 0a 09 09 09 09 09 09 09 09 09 20 28 66 69 6c 74 .......... (filt 1bd0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x).. 1be0: 09 09 09 09 09 09 09 09 09 20 20 20 28 65 71 3f ......... (eq? 1bf0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref 1c00: 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 /default test-re 1c10: 67 69 73 74 72 79 20 78 20 23 66 29 20 27 73 74 gistry x #f) 'st 1c20: 61 72 74 29 29 0a 09 09 09 09 09 09 09 09 09 09 art))........... 1c30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key 1c40: 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 29 s test-registry) 1c50: 29 0a 09 09 09 09 09 09 09 09 09 20 22 2c 20 22 ).......... ", " 1c60: 29 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 ))... (thread-s 1c70: 6c 65 65 70 21 20 30 2e 31 29 0a 09 09 20 20 28 leep! 0.1)... ( 1c80: 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 65 72 loop hed tal rer 1c90: 75 6e 73 29 29 0a 09 09 20 28 28 6e 6f 74 20 68 uns))... ((not h 1ca0: 61 76 65 2d 72 65 73 6f 75 72 63 65 73 29 20 3b ave-resources) ; 1cb0: 3b 20 73 69 6d 70 6c 79 20 74 72 79 20 61 67 61 ; simply try aga 1cc0: 69 6e 20 61 66 74 65 72 20 77 61 69 74 69 6e 67 in after waiting 1cd0: 20 61 20 73 65 63 6f 6e 64 0a 09 09 20 20 28 64 a second... (d 1ce0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info 1cf0: 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 73 20 1 "no resources 1d00: 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 73 to run new tests 1d10: 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 0a , waiting ..."). 1d20: 09 09 20 20 3b 3b 20 48 61 76 65 20 67 6f 6e 65 .. ;; Have gone 1d30: 20 62 61 63 6b 20 61 6e 64 20 66 6f 72 74 68 20 back and forth 1d40: 6f 6e 20 74 68 69 73 20 62 75 74 20 64 62 20 73 on this but db s 1d50: 74 61 72 76 61 74 69 6f 6e 20 69 73 20 61 6e 20 tarvation is an 1d60: 69 73 73 75 65 2e 0a 09 09 20 20 3b 3b 20 77 61 issue.... ;; wa 1d70: 69 74 20 6f 6e 65 20 73 65 63 6f 6e 64 20 62 65 it one second be 1d80: 66 6f 72 65 20 6c 6f 6f 6b 69 6e 67 20 61 67 61 fore looking aga 1d90: 69 6e 20 74 6f 20 72 75 6e 20 6a 6f 62 73 2e 0a in to run jobs.. 1da0: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee 1db0: 70 21 20 31 29 20 3b 3b 20 28 2b 20 32 20 2a 67 p! 1) ;; (+ 2 *g 1dc0: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 lobal-delta*)).. 1dd0: 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 65 . ;; could have 1de0: 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 65 done hed tal he 1df0: 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 61 72 re but doing car 1e00: 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 74 /cdr of newtal t 1e10: 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 0a 09 o rotate tests.. 1e20: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 . (loop (car ne 1e30: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal 1e40: 29 20 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 ) reruns))... (( 1e50: 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 72 63 and have-resourc 1e60: 65 73 0a 09 09 20 20 20 20 20 20 20 28 6f 72 20 es... (or 1e70: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n 1e80: 6f 74 2d 6d 65 74 29 0a 09 09 09 20 20 20 28 61 ot-met).... (a 1e90: 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 nd (eq? testmode 1ea0: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 'toplevel)..... 1eb0: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl 1ec0: 65 74 65 64 29 29 29 29 0a 09 09 20 20 28 72 75 eted))))... (ru 1ed0: 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 n:test run-id ru 1ee0: 6e 2d 69 6e 66 6f 20 6b 65 79 2d 76 61 6c 73 20 n-info key-vals 1ef0: 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 runname keyvalls 1f00: 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c t test-record fl 1f10: 61 67 73 20 23 66 29 0a 09 09 20 20 28 68 61 73 ags #f)... (has 1f20: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes 1f30: 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 t-registry (runs 1f40: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test- 1f50: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i 1f60: 74 65 6d 2d 70 61 74 68 29 20 27 72 75 6e 6e 69 tem-path) 'runni 1f70: 6e 67 29 0a 09 09 20 20 28 72 75 6e 73 3a 73 68 ng)... (runs:sh 1f80: 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 rink-can-run-mor 1f90: 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 20 e-tests-count) 1fa0: 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 ;; DELAY TWEAKER 1fb0: 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 (still needed?) 1fc0: 0a 09 09 20 20 3b 3b 20 28 74 68 72 65 61 64 2d ... ;; (thread- 1fd0: 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 sleep! *global-d 1fe0: 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 20 28 elta*)... (if ( 1ff0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal)) 2000: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop ( 2010: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal 2020: 29 20 72 65 72 75 6e 73 29 29 29 0a 09 09 20 28 ) reruns)))... ( 2030: 65 6c 73 65 20 3b 3b 20 6d 75 73 74 20 62 65 20 else ;; must be 2040: 77 65 20 68 61 76 65 20 75 6e 6d 65 74 20 70 72 we have unmet pr 2050: 65 72 65 71 75 69 73 69 74 65 73 0a 09 09 20 20 erequisites... 2060: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4 2070: 20 22 46 41 49 4c 53 3a 20 22 20 66 61 69 6c 73 "FAILS: " fails 2080: 29 0a 09 09 20 20 20 20 3b 3b 20 49 66 20 6f 6e )... ;; If on 2090: 65 20 6f 72 20 6d 6f 72 65 20 6f 66 20 74 68 65 e or more of the 20a0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met 20b0: 20 61 72 65 20 46 41 49 4c 20 74 68 65 6e 20 77 are FAIL then w 20c0: 65 20 63 61 6e 20 69 73 73 75 65 0a 09 09 20 20 e can issue... 20d0: 20 20 3b 3b 20 61 20 6d 65 73 73 61 67 65 20 61 ;; a message a 20e0: 6e 64 20 64 72 6f 70 20 68 65 64 20 66 72 6f 6d nd drop hed from 20f0: 20 74 68 65 20 69 74 65 6d 73 20 74 6f 20 62 65 the items to be 2100: 20 70 72 6f 63 65 73 73 65 64 2e 0a 09 09 20 20 processed.... 2110: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 (if (null? fai 2120: 6c 73 29 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 ls)....(begin... 2130: 09 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 . ;; couldn't r 2140: 75 6e 2c 20 74 61 6b 65 20 61 20 62 72 65 61 74 un, take a breat 2150: 68 65 72 0a 09 09 09 20 20 28 64 65 62 75 67 3a her.... (debug: 2160: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 53 68 print-info 4 "Sh 2170: 6f 75 6c 64 6e 27 74 20 72 65 61 6c 6c 79 20 67 ouldn't really g 2180: 65 74 20 68 65 72 65 2c 20 72 61 63 65 20 63 6f et here, race co 2190: 6e 64 69 74 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 ndition? Unable 21a0: 74 6f 20 6c 61 75 6e 63 68 20 6d 6f 72 65 20 74 to launch more t 21b0: 65 73 74 73 20 61 74 20 74 68 69 73 20 6d 6f 6d ests at this mom 21c0: 65 6e 74 2c 20 6b 69 6c 6c 69 6e 67 20 74 69 6d ent, killing tim 21d0: 65 20 2e 2e 2e 22 29 0a 09 09 09 20 20 3b 3b 20 e ...").... ;; 21e0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! ( 21f0: 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 + 0.01 *global-d 2200: 65 6c 74 61 2a 29 29 20 3b 3b 20 6c 6f 6e 67 20 elta*)) ;; long 2210: 73 6c 65 65 70 20 68 65 72 65 20 2d 20 6e 6f 20 sleep here - no 2220: 72 65 73 6f 75 72 63 65 73 2c 20 6d 61 79 20 61 resources, may a 2230: 73 20 77 65 6c 6c 20 62 65 20 70 61 74 69 65 6e s well be patien 2240: 74 0a 09 09 09 20 20 3b 3b 20 77 65 20 6d 61 64 t.... ;; we mad 2250: 65 20 6e 65 77 20 74 61 6c 20 62 79 20 73 74 69 e new tal by sti 2260: 63 6b 69 6e 67 20 68 65 64 20 61 74 20 74 68 65 cking hed at the 2270: 20 62 61 63 6b 20 6f 66 20 74 68 65 20 6c 69 73 back of the lis 2280: 74 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 t.... (loop (ca 2290: 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 r newtal)(cdr ne 22a0: 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 wtal) reruns)).. 22b0: 09 09 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 20 ..;; the waiton 22c0: 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f 20 70 6f is FAIL so no po 22d0: 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 20 74 6f int in trying to 22e0: 20 72 75 6e 20 68 65 64 20 65 76 65 72 20 61 67 run hed ever ag 22f0: 61 69 6e 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 ain....(if (not 2300: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 (null? tal)).... 2310: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector? 2320: 20 68 65 64 29 0a 09 09 09 09 28 62 65 67 69 6e hed).....(begin 2330: 20 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 ..... (debug:p 2340: 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 44 72 rint 1 "WARN: Dr 2350: 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 28 64 opping test " (d 2360: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn 2370: 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 64 62 ame hed) "/" (db 2380: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p 2390: 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 20 20 ath hed)...... 23a0: 20 20 20 20 20 22 20 66 72 6f 6d 20 74 68 65 20 " from the 23b0: 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 69 launch list as i 23c0: 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 t has prerequist 23d0: 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c es that are FAIL 23e0: 22 29 0a 09 09 09 09 20 20 28 72 75 6e 73 3a 73 ")..... (runs:s 23f0: 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f hrink-can-run-mo 2400: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 re-tests-count) 2410: 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 ;; DELAY TWEAKER 2420: 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 (still needed?) 2430: 0a 09 09 09 09 20 20 3b 3b 20 28 74 68 72 65 61 ..... ;; (threa 2440: 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c d-sleep! *global 2450: 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 20 28 -delta*)..... ( 2460: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set! 2470: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r 2480: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te 2490: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam 24a0: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 72 65 e item-path) 're 24b0: 6d 6f 76 65 64 29 0a 09 09 09 09 20 20 28 6c 6f moved)..... (lo 24c0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr 24d0: 20 74 61 6c 29 20 28 63 6f 6e 73 20 68 65 64 20 tal) (cons hed 24e0: 72 65 72 75 6e 73 29 29 29 0a 09 09 09 09 28 62 reruns))).....(b 24f0: 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 egin..... (debu 2500: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a g:print 1 "WARN: 2510: 20 54 65 73 74 20 6e 6f 74 20 70 72 6f 63 65 73 Test not proces 2520: 73 65 64 20 63 6f 72 72 65 63 74 6c 79 2e 20 43 sed correctly. C 2530: 6f 75 6c 64 20 62 65 20 61 20 72 61 63 65 20 63 ould be a race c 2540: 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 79 6f 75 72 ondition in your 2550: 20 74 65 73 74 20 69 6d 70 6c 65 6d 65 6e 74 61 test implementa 2560: 74 69 6f 6e 3f 20 22 20 68 65 64 29 20 3b 3b 20 tion? " hed) ;; 2570: 20 22 20 61 73 20 69 74 20 68 61 73 20 70 72 65 " as it has pre 2580: 72 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 requistes that a 2590: 72 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 3a 20 re FAIL. (NOTE: 25a0: 68 65 64 20 69 73 20 6e 6f 74 20 61 20 76 65 63 hed is not a vec 25b0: 74 6f 72 29 22 29 0a 09 09 09 09 20 20 28 72 75 tor)")..... (ru 25c0: 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 ns:shrink-can-ru 25d0: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 n-more-tests-cou 25e0: 6e 74 29 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 nt) ;; DELAY TWE 25f0: 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 AKER (still need 2600: 65 64 3f 29 0a 09 09 09 09 20 20 3b 3b 20 28 74 ed?)..... ;; (t 2610: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 hread-sleep! (+ 2620: 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 0.01 *global-del 2630: 74 61 2a 29 29 0a 09 09 09 09 20 20 28 6c 6f 6f ta*))..... (loo 2640: 70 20 68 65 64 20 74 61 6c 20 72 65 72 75 6e 73 p hed tal reruns 2650: 29 29 29 29 29 29 29 29 29 20 3b 3b 20 45 4e 44 ))))))))) ;; END 2660: 20 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 0a 09 OF INNER COND.. 2670: 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b 20 63 .. ;; c 2680: 61 73 65 20 77 68 65 72 65 20 61 6e 20 69 74 65 ase where an ite 2690: 6d 73 20 63 61 6d 65 20 69 6e 20 61 73 20 61 20 ms came in as a 26a0: 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 65 73 list been proces 26b0: 73 65 64 0a 09 20 20 20 20 20 28 28 61 6e 64 20 sed.. ((and 26c0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 20 20 (list? items) 26d0: 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b 6e 6f ;; thus we kno 26e0: 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 65 20 w our items are 26f0: 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c 61 74 already calculat 2700: 65 64 0a 09 09 20 20 20 28 6e 6f 74 20 20 20 69 ed... (not i 2710: 74 65 6d 64 61 74 29 29 20 3b 3b 20 61 6e 64 20 temdat)) ;; and 2720: 6e 6f 74 20 79 65 74 20 65 78 70 61 6e 64 65 64 not yet expanded 2730: 20 69 6e 74 6f 20 74 68 65 20 6c 69 73 74 20 6f into the list o 2740: 66 20 74 68 69 6e 67 73 20 74 6f 20 62 65 20 64 f things to be d 2750: 6f 6e 65 0a 09 20 20 20 20 20 20 28 69 66 20 28 one.. (if ( 2760: 61 6e 64 20 28 64 65 62 75 67 3a 64 65 62 75 67 and (debug:debug 2770: 2d 6d 6f 64 65 20 31 29 20 3b 3b 20 28 3e 3d 20 -mode 1) ;; (>= 2780: 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 0a 09 *verbosity* 1).. 2790: 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 . (> (leng 27a0: 74 68 20 69 74 65 6d 73 29 20 30 29 0a 09 09 20 th items) 0)... 27b0: 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 (> (length 27c0: 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 (car items)) 0) 27d0: 29 0a 09 09 20 20 28 70 70 20 69 74 65 6d 73 29 )... (pp items) 27e0: 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 ).. (for-ea 27f0: 63 68 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 ch.. (lamb 2800: 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a da (my-itemdat). 2810: 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 .. (let* ((new-t 2820: 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 est-record (let 2830: 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 ((newrec (make-t 2840: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 29 29 ests:testqueue)) 2850: 29 0a 09 09 09 09 09 20 20 20 28 76 65 63 74 6f )...... (vecto 2860: 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 r-copy! test-rec 2870: 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 ord newrec)..... 2880: 09 20 20 20 6e 65 77 72 65 63 29 29 0a 09 09 09 . newrec)).... 2890: 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 28 69 (my-item-path (i 28a0: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 6d tem-list->path m 28b0: 79 2d 69 74 65 6d 64 61 74 29 29 29 0a 09 09 20 y-itemdat)))... 28c0: 20 20 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 (if (tests:mat 28d0: 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 68 65 ch test-patts he 28e0: 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 72 d my-item-path r 28f0: 65 71 75 69 72 65 64 3a 20 72 65 71 75 69 72 65 equired: require 2900: 64 2d 74 65 73 74 73 29 20 3b 3b 20 28 70 61 74 d-tests) ;; (pat 2910: 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 6d 79 2d t-list-match my- 2920: 69 74 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 item-path item-p 2930: 61 74 74 73 29 20 20 20 20 20 20 20 20 20 20 20 atts) 2940: 3b 3b 20 79 65 73 2c 20 77 65 20 77 61 6e 74 20 ;; yes, we want 2950: 74 6f 20 70 72 6f 63 65 73 73 20 74 68 69 73 20 to process this 2960: 69 74 65 6d 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 item, NOTE: Shou 2970: 6c 64 20 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 ld not need this 2980: 20 63 68 65 63 6b 20 68 65 72 65 21 0a 09 09 20 check here!... 2990: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 (let ((new 29a0: 74 65 73 74 6e 61 6d 65 20 28 72 75 6e 73 3a 6d testname (runs:m 29b0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na 29c0: 6d 65 20 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 me hed my-item-p 29d0: 61 74 68 29 29 29 20 20 20 20 3b 3b 20 74 65 73 ath))) ;; tes 29e0: 74 20 6e 61 6d 65 73 20 61 72 65 20 75 6e 69 71 t names are uniq 29f0: 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d 65 2f 69 ue on testname/i 2a00: 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 28 74 65 tem-path.... (te 2a10: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se 2a20: 74 2d 69 74 65 6d 73 21 20 20 20 20 20 6e 65 77 t-items! new 2a30: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 -test-record #f) 2a40: 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 .... (tests:test 2a50: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 queue-set-itemda 2a60: 74 21 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 t! new-test-re 2a70: 63 6f 72 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 cord my-itemdat) 2a80: 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 .... (tests:test 2a90: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 queue-set-item_p 2aa0: 61 74 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 ath! new-test-re 2ab0: 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 cord my-item-pat 2ac0: 68 29 0a 09 09 09 20 28 68 61 73 68 2d 74 61 62 h).... (hash-tab 2ad0: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec 2ae0: 6f 72 64 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 ords newtestname 2af0: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record 2b00: 29 0a 09 09 09 20 28 73 65 74 21 20 74 61 6c 20 ).... (set! tal 2b10: 28 63 6f 6e 73 20 6e 65 77 74 65 73 74 6e 61 6d (cons newtestnam 2b20: 65 20 74 61 6c 29 29 29 29 29 29 20 3b 3b 20 73 e tal)))))) ;; s 2b30: 69 6e 63 65 20 74 68 65 73 65 20 61 72 65 20 69 ince these are i 2b40: 74 65 6d 69 7a 65 64 20 63 72 65 61 74 65 20 6e temized create n 2b50: 65 77 20 74 65 73 74 20 6e 61 6d 65 73 20 74 65 ew test names te 2b60: 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a stname/itempath. 2b70: 09 20 20 20 20 20 20 20 69 74 65 6d 73 29 0a 09 . items).. 2b80: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not ( 2b90: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 null? tal))... 2ba0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 (begin... (de 2bb0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4 2bc0: 20 22 45 6e 64 20 6f 66 20 69 74 65 6d 73 20 6c "End of items l 2bd0: 69 73 74 2c 20 6c 6f 6f 70 69 6e 67 20 77 69 74 ist, looping wit 2be0: 68 20 6e 65 78 74 20 61 66 74 65 72 20 73 68 6f h next after sho 2bf0: 72 74 20 64 65 6c 61 79 22 29 0a 20 20 20 20 20 rt delay"). 2c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ; 2c10: 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ; (thread-sleep! 2c20: 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c (+ 0.01 *global 2c30: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 -delta*))... 2c40: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)( 2c50: 63 64 72 20 74 61 6c 29 20 72 65 72 75 6e 73 29 cdr tal) reruns) 2c60: 29 29 29 0a 0a 09 20 20 20 20 20 3b 3b 20 69 66 )))... ;; if 2c70: 20 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 items is a proc 2c80: 20 74 68 65 6e 20 6e 65 65 64 20 74 6f 20 72 75 then need to ru 2c90: 6e 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d n items:get-item 2ca0: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 s-from-config, g 2cb0: 65 74 20 74 68 65 20 6c 69 73 74 20 61 6e 64 20 et the list and 2cc0: 6c 6f 6f 70 20 0a 09 20 20 20 20 20 3b 3b 20 20 loop .. ;; 2cd0: 20 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 - but only do 2ce0: 74 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 that if resource 2cf0: 73 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 s exist to kick 2d00: 6f 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 20 20 off the job.. 2d10: 20 20 28 28 6f 72 20 28 70 72 6f 63 65 64 75 72 ((or (procedur 2d20: 65 3f 20 69 74 65 6d 73 29 28 65 71 3f 20 69 74 e? items)(eq? it 2d30: 65 6d 73 20 27 68 61 76 65 2d 70 72 6f 63 65 64 ems 'have-proced 2d40: 75 72 65 29 29 0a 09 20 20 20 20 20 20 28 6c 65 ure)).. (le 2d50: 74 20 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 t ((can-run-more 2d60: 20 20 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 (runs:can-ru 2d70: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 74 65 73 n-more-tests tes 2d80: 74 2d 72 65 63 6f 72 64 20 6d 61 78 2d 63 6f 6e t-record max-con 2d90: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a current-jobs))). 2da0: 09 09 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 ..(if (and (list 2db0: 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a ? can-run-more). 2dc0: 09 09 09 20 28 63 61 72 20 63 61 6e 2d 72 75 6e ... (car can-run 2dd0: 2d 6d 6f 72 65 29 29 0a 09 09 20 20 20 20 28 6c -more))... (l 2de0: 65 74 2a 20 28 28 70 72 65 72 65 71 73 2d 6e 6f et* ((prereqs-no 2df0: 74 2d 6d 65 74 20 28 64 62 3a 67 65 74 2d 70 72 t-met (db:get-pr 2e00: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru 2e10: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite 2e20: 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 m-path mode: tes 2e30: 74 6d 6f 64 65 29 29 0a 09 09 09 20 20 20 28 66 tmode)).... (f 2e40: 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 28 ails ( 2e50: 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 runs:calc-fails 2e60: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met) 2e70: 29 0a 09 09 09 20 20 20 28 6e 6f 6e 2d 63 6f 6d ).... (non-com 2e80: 70 6c 65 74 65 64 20 20 20 28 72 75 6e 73 3a 63 pleted (runs:c 2e90: 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 alc-not-complete 2ea0: 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 d prereqs-not-me 2eb0: 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 t)))... (de 2ec0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8 2ed0: 20 22 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 "can-run-more: 2ee0: 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 " can-run-more.. 2ef0: 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6e 61 ... "\n testna 2f00: 6d 65 3a 20 20 20 20 20 20 20 20 22 20 68 65 64 me: " hed 2f10: 0a 09 09 09 09 20 20 20 22 5c 6e 20 70 72 65 72 ..... "\n prer 2f20: 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 eqs-not-met: " ( 2f30: 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 runs:pretty-stri 2f40: 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ng prereqs-not-m 2f50: 65 74 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 6e et)..... "\n n 2f60: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 3a 20 20 20 on-completed: 2f70: 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 " (runs:pretty-s 2f80: 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 tring non-comple 2f90: 74 65 64 29 20 0a 09 09 09 09 20 20 20 22 5c 6e ted) ..... "\n 2fa0: 20 66 61 69 6c 73 3a 20 20 20 20 20 20 20 20 20 fails: 2fb0: 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 " (runs:pretty 2fc0: 2d 73 74 72 69 6e 67 20 66 61 69 6c 73 29 0a 09 -string fails).. 2fd0: 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6d 6f ... "\n testmo 2fe0: 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 73 de: " tes 2ff0: 74 6d 6f 64 65 0a 09 09 09 09 20 20 20 22 5c 6e tmode..... "\n 3000: 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 20 20 num-retries: 3010: 20 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 0a " num-retries. 3020: 09 09 09 09 20 20 20 22 5c 6e 20 28 65 71 3f 20 .... "\n (eq? 3030: 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 testmode 'toplev 3040: 65 6c 29 3a 20 22 20 28 65 71 3f 20 74 65 73 74 el): " (eq? test 3050: 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a mode 'toplevel). 3060: 09 09 09 09 20 20 20 22 5c 6e 20 28 6e 75 6c 6c .... "\n (null 3070: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed) 3080: 3a 20 20 20 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f : " (null? no 3090: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 0a 09 09 09 n-completed).... 30a0: 09 20 20 20 22 5c 6e 20 72 65 72 75 6e 73 3a 20 . "\n reruns: 30b0: 20 20 20 20 20 20 20 20 20 22 20 72 65 72 75 6e " rerun 30c0: 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 69 74 65 s..... "\n ite 30d0: 6d 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 ms: " 30e0: 69 74 65 6d 73 0a 09 09 09 09 20 20 20 22 5c 6e items..... "\n 30f0: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 can-run-more: 3100: 20 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 " can-run-more 3110: 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 74 68 )... ;; (th 3120: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 read-sleep! (+ 0 3130: 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 .01 *global-delt 3140: 61 2a 29 29 0a 09 09 20 20 20 20 20 20 28 63 6f a*))... (co 3150: 6e 64 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 nd ;; INNER COND 3160: 20 23 32 0a 09 09 20 20 20 20 20 20 20 28 28 6f #2... ((o 3170: 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 r (null? prereqs 3180: 2d 6e 6f 74 2d 6d 65 74 29 20 3b 3b 20 61 6c 6c -not-met) ;; all 3190: 20 70 72 65 72 65 71 73 20 6d 65 74 2c 20 66 69 prereqs met, fi 31a0: 72 65 20 6f 66 66 20 74 68 65 20 74 65 73 74 0a re off the test. 31b0: 09 09 09 20 20 20 20 3b 3b 20 6f 72 2c 20 69 66 ... ;; or, if 31c0: 20 69 74 20 69 73 20 61 20 27 74 6f 70 6c 65 76 it is a 'toplev 31d0: 65 6c 20 74 65 73 74 20 61 6e 64 20 61 6c 6c 20 el test and all 31e0: 70 72 65 72 65 71 73 20 6e 6f 74 20 6d 65 74 20 prereqs not met 31f0: 61 72 65 20 43 4f 4d 50 4c 45 54 45 44 20 74 68 are COMPLETED th 3200: 65 6e 20 6c 61 75 6e 63 68 0a 09 09 09 20 20 20 en launch.... 3210: 20 28 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d (and (eq? testm 3220: 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 ode 'toplevel).. 3230: 09 09 09 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 ... (null? non-c 3240: 6f 6d 70 6c 65 74 65 64 29 29 29 0a 09 09 09 28 ompleted)))....( 3250: 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 let ((test-name 3260: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue 3270: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te 3280: 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 09 09 st-record))).... 3290: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE 32a0: 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 ST_NAME" test-na 32b0: 6d 65 29 20 3b 3b 20 0a 09 09 09 20 20 28 73 65 me) ;; .... (se 32c0: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 tenv "MT_RUNNAME 32d0: 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 09 " runname).... 32e0: 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d (set-megatest- 32f0: 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 env-vars run-id 3300: 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 inrunname: runna 3310: 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 me) ;; these may 3320: 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 be needed by th 3330: 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 e launching proc 3340: 65 73 73 0a 09 09 09 20 20 28 6c 65 74 20 28 28 ess.... (let (( 3350: 69 74 65 6d 73 2d 6c 69 73 74 20 28 69 74 65 6d items-list (item 3360: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from 3370: 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 -config tconfig) 3380: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 6c )).... (if (l 3390: 69 73 74 3f 20 69 74 65 6d 73 2d 6c 69 73 74 29 ist? items-list) 33a0: 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 .....(begin..... 33b0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque 33c0: 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 74 65 ue-set-items! te 33d0: 73 74 2d 72 65 63 6f 72 64 20 69 74 65 6d 73 2d st-record items- 33e0: 6c 69 73 74 29 0a 09 09 09 09 20 20 3b 3b 20 28 list)..... ;; ( 33f0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 thread-sleep! *g 3400: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 lobal-delta*)... 3410: 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 .. (loop hed ta 3420: 6c 20 72 65 72 75 6e 73 29 29 0a 09 09 09 09 28 l reruns)).....( 3430: 62 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 begin..... (deb 3440: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO 3450: 52 3a 20 54 68 65 20 70 72 6f 63 20 66 72 6f 6d R: The proc from 3460: 20 72 65 61 64 69 6e 67 20 74 68 65 20 73 65 74 reading the set 3470: 75 70 20 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 up did not yield 3480: 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 a list - please 3490: 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 report this").. 34a0: 09 09 09 20 20 28 65 78 69 74 20 31 29 29 29 29 ... (exit 1)))) 34b0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 28 6e 75 ))... ((nu 34c0: 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 64 ll? fails)....(d 34d0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info 34e0: 34 20 22 66 61 69 6c 73 20 69 73 20 6e 75 6c 6c 4 "fails is null 34f0: 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 69 6e 20 74 , moving on in t 3500: 68 65 20 71 75 65 75 65 20 62 75 74 20 6b 65 65 he queue but kee 3510: 70 69 6e 67 20 22 20 68 65 64 20 22 20 66 6f 72 ping " hed " for 3520: 20 6e 6f 77 22 29 0a 09 09 09 3b 3b 20 6f 6e 6c now")....;; onl 3530: 79 20 69 6e 63 72 65 6d 65 6e 74 20 6e 75 6d 2d y increment num- 3540: 72 65 74 72 69 65 73 20 77 68 65 6e 20 74 68 65 retries when the 3550: 72 65 20 61 72 65 20 6e 6f 20 74 65 73 74 73 20 re are no tests 3560: 72 75 6e 69 6e 67 0a 09 09 09 28 69 66 20 28 65 runing....(if (e 3570: 71 3f 20 30 20 28 6c 69 73 74 2d 72 65 66 20 63 q? 0 (list-ref c 3580: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 31 29 29 0a an-run-more 1)). 3590: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin... 35a0: 09 20 20 20 20 20 20 3b 3b 20 54 52 59 20 28 69 . ;; TRY (i 35b0: 66 20 28 3e 20 6e 75 6d 2d 72 65 74 72 69 65 73 f (> num-retries 35c0: 20 31 30 30 29 20 3b 3b 20 66 69 72 73 74 20 31 100) ;; first 1 35d0: 30 30 20 72 65 74 72 69 65 73 20 61 72 65 20 6c 00 retries are l 35e0: 6f 77 20 74 69 6d 65 20 63 6f 73 74 0a 09 09 09 ow time cost.... 35f0: 20 20 20 20 20 20 3b 3b 20 54 52 59 20 20 20 20 ;; TRY 3600: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep! 3610: 28 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c (+ 2 *global-del 3620: 74 61 2a 29 29 0a 09 09 09 20 20 20 20 20 20 3b ta*)).... ; 3630: 3b 20 54 52 59 20 20 20 20 20 28 74 68 72 65 61 ; TRY (threa 3640: 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 d-sleep! (+ 0.01 3650: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*) 3660: 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 )).... (set 3670: 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b ! num-retries (+ 3680: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 num-retries 1)) 3690: 29 29 0a 09 09 09 28 69 66 20 28 3e 20 6e 75 6d ))....(if (> num 36a0: 2d 72 65 74 72 69 65 73 20 20 6d 61 78 2d 72 65 -retries max-re 36b0: 74 72 69 65 73 29 0a 09 09 09 20 20 20 20 28 69 tries).... (i 36c0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta 36d0: 6c 29 29 0a 09 09 09 09 28 6c 6f 6f 70 20 28 63 l)).....(loop (c 36e0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal) 36f0: 20 72 65 72 75 6e 73 29 29 0a 09 09 09 20 20 20 reruns)).... 3700: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt 3710: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal) 3720: 72 65 72 75 6e 73 29 29 29 20 3b 3b 20 61 6e 20 reruns))) ;; an 3730: 69 73 73 75 65 20 77 69 74 68 20 70 72 65 72 65 issue with prere 3740: 71 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a qs not yet met?. 3750: 09 09 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 .. ((and ( 3760: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 not (null? fails 3770: 29 29 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 ))(eq? testmode 3780: 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 65 'normal))....(de 3790: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1 37a0: 20 22 74 65 73 74 20 22 20 20 68 65 64 20 22 20 "test " hed " 37b0: 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 (mode=" testmode 37c0: 20 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 70 ") has failed p 37d0: 72 65 72 65 71 75 69 73 69 74 65 28 73 29 3b 20 rerequisite(s); 37e0: 22 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 "..... (stri 37f0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse ( 3800: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 28 map (lambda (t)( 3810: 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 conc (db:test-ge 3820: 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a t-testname t) ": 3830: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s 3840: 74 61 74 65 20 74 29 22 2f 22 28 64 62 3a 74 65 tate t)"/"(db:te 3850: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 st-get-status t) 3860: 29 29 20 66 61 69 6c 73 29 20 22 2c 20 22 29 0a )) fails) ", "). 3870: 09 09 09 09 20 20 20 20 20 22 2c 20 72 65 6d 6f .... ", remo 3880: 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d ving it from to- 3890: 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 69 66 do list")....(if 38a0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal 38b0: 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 6e )).... (begin 38c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 38d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ; 38e0: 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ; (thread-sleep! 38f0: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*) 3900: 0a 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 .... (loop 3910: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta 3920: 6c 29 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 l)(cons hed reru 3930: 6e 73 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 ns)))))... 3940: 20 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 67 (else....(debug 3950: 3a 70 72 69 6e 74 20 38 20 22 45 52 52 4f 52 3a :print 8 "ERROR: 3960: 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 6f 72 20 No handler for 3970: 74 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 2e 22 this condition." 3980: 29 0a 09 09 09 3b 3b 20 54 52 59 20 28 74 68 72 )....;; TRY (thr 3990: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 ead-sleep! (+ 1 39a0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*)) 39b0: 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e ....(loop (car n 39c0: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta 39d0: 6c 29 20 72 65 72 75 6e 73 29 29 29 29 20 3b 3b l) reruns)))) ;; 39e0: 20 45 4e 44 20 4f 46 20 49 46 20 43 41 4e 20 52 END OF IF CAN R 39f0: 55 4e 20 4d 4f 52 45 0a 0a 09 09 20 20 20 20 3b UN MORE.... ; 3a00: 3b 20 69 66 20 63 61 6e 27 74 20 72 75 6e 20 6d ; if can't run m 3a10: 6f 72 65 20 6a 75 73 74 20 6c 6f 6f 70 20 77 69 ore just loop wi 3a20: 74 68 20 6e 65 78 74 20 70 6f 73 73 69 62 6c 65 th next possible 3a30: 20 74 65 73 74 0a 09 09 20 20 20 20 28 62 65 67 test... (beg 3a40: 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 in... (debu 3a50: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 " 3a60: 70 72 6f 63 65 73 73 69 6e 67 20 74 68 65 20 63 processing the c 3a70: 61 73 65 20 77 69 74 68 20 61 20 6c 61 6d 62 64 ase with a lambd 3a80: 61 20 66 6f 72 20 69 74 65 6d 73 20 6f 72 20 27 a for items or ' 3a90: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 2e 20 have-procedure. 3aa0: 4d 6f 76 69 6e 67 20 74 68 72 6f 75 67 68 20 74 Moving through t 3ab0: 68 65 20 71 75 65 75 65 20 77 69 74 68 6f 75 74 he queue without 3ac0: 20 64 72 6f 70 70 69 6e 67 20 22 20 68 65 64 29 dropping " hed) 3ad0: 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 74 68 72 ... ;; (thr 3ae0: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 32 20 ead-sleep! (+ 2 3af0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*)) 3b00: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop ( 3b10: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr 3b20: 6e 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 newtal) reruns)) 3b30: 29 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 28 6f ))) ;; END OF (o 3b40: 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 r (procedure? it 3b50: 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 ems)(eq? items ' 3b60: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 have-procedure)) 3b70: 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b .. .. ;; 3b80: 20 74 68 69 73 20 63 61 73 65 20 73 68 6f 75 6c this case shoul 3b90: 64 20 6e 6f 74 20 68 61 70 70 65 6e 2c 20 61 64 d not happen, ad 3ba0: 64 65 64 20 74 6f 20 68 65 6c 70 20 63 61 74 63 ded to help catc 3bb0: 68 20 61 6e 79 20 62 75 67 73 0a 09 20 20 20 20 h any bugs.. 3bc0: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 ((and (list? it 3bd0: 65 6d 73 29 20 69 74 65 6d 64 61 74 29 0a 09 20 ems) itemdat).. 3be0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin 3bf0: 74 20 30 20 22 45 52 52 4f 52 3a 20 53 68 6f 75 t 0 "ERROR: Shou 3c00: 6c 64 20 6e 6f 74 20 68 61 76 65 20 61 20 6c 69 ld not have a li 3c10: 73 74 20 6f 66 20 69 74 65 6d 73 20 69 6e 20 61 st of items in a 3c20: 20 74 65 73 74 20 61 6e 64 20 74 68 65 20 69 74 test and the it 3c30: 65 6d 73 70 61 74 68 20 73 65 74 20 2d 20 70 6c emspath set - pl 3c40: 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 ease report this 3c50: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit 3c60: 31 29 29 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 1)).. ((not 3c70: 28 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 0a (null? reruns)). 3c80: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e . (let* ((n 3c90: 65 77 6c 73 74 20 28 74 65 73 74 73 3a 66 69 6c ewlst (tests:fil 3ca0: 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 ter-non-runnable 3cb0: 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 74 run-id tal test 3cc0: 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 69 2e -records)) ;; i. 3cd0: 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 41 49 e. not FAIL, WAI 3ce0: 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 2c VED, INCOMPLETE, 3cf0: 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a 09 PASS, KILLED,.. 3d00: 09 20 20 20 20 20 28 6a 75 6e 6b 65 64 20 28 6c . (junked (l 3d10: 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 20 65 set-difference e 3d20: 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 74 qual? tal newlst 3d30: 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 )))...(debug:pri 3d40: 6e 74 2d 69 6e 66 6f 20 34 20 22 66 75 6c 6c 20 nt-info 4 "full 3d50: 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 69 66 drop through, if 3d60: 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 73 20 reruns is less 3d70: 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 6c 6c than 100 we will 3d80: 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 68 65 force retry the 3d90: 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 m, reruns=" reru 3da0: 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c 29 ns ", tal=" tal) 3db0: 0a 09 09 28 69 66 20 28 3c 20 6e 75 6d 2d 72 65 ...(if (< num-re 3dc0: 74 72 69 65 73 20 6d 61 78 2d 72 65 74 72 69 65 tries max-retrie 3dd0: 73 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 6e s)... (set! n 3de0: 65 77 6c 73 74 20 28 61 70 70 65 6e 64 20 72 65 ewlst (append re 3df0: 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 0a 09 runs newlst))).. 3e00: 09 28 73 65 74 21 20 6e 75 6d 2d 72 65 74 72 69 .(set! num-retri 3e10: 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 72 69 65 es (+ num-retrie 3e20: 73 20 31 29 29 0a 09 09 3b 3b 20 28 74 68 72 65 s 1))...;; (thre 3e30: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a ad-sleep! (+ 1 * 3e40: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a global-delta*)). 3e50: 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ..(if (not (null 3e60: 3f 20 6e 65 77 6c 73 74 29 29 0a 09 09 20 20 20 ? newlst))... 3e70: 20 3b 3b 20 73 69 6e 63 65 20 72 65 72 75 6e 73 ;; since reruns 3e80: 20 68 61 76 65 20 62 65 65 6e 20 74 61 63 6b 65 have been tacke 3e90: 64 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 74 20 63 d on to newlst c 3ea0: 72 65 61 74 65 20 6e 65 77 20 72 65 72 75 6e 73 reate new reruns 3eb0: 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a 09 09 20 from junked... 3ec0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne 3ed0: 77 6c 73 74 29 28 63 64 72 20 6e 65 77 6c 73 74 wlst)(cdr newlst 3ee0: 29 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 )(delete-duplica 3ef0: 74 65 73 20 6a 75 6e 6b 65 64 29 29 29 29 29 0a tes junked))))). 3f00: 09 20 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c . ((not (nul 3f10: 6c 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 l? tal)).. 3f20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf 3f30: 6f 20 34 20 22 49 27 6d 20 70 72 65 74 74 79 20 o 4 "I'm pretty 3f40: 73 75 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 sure I shouldn't 3f50: 20 67 65 74 20 68 65 72 65 2e 22 29 29 0a 09 20 get here.")).. 3f60: 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 (else.. 3f70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in 3f80: 66 6f 20 34 20 22 45 78 69 74 69 6e 67 20 6c 6f fo 4 "Exiting lo 3f90: 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 68 65 op with...\n he 3fa0: 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 61 6c d=" hed "\n tal 3fb0: 3d 22 20 74 61 6c 20 22 5c 6e 20 20 72 65 72 75 =" tal "\n reru 3fc0: 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 20 ns=" reruns)).. 3fd0: 20 20 20 20 29 29 29 29 20 3b 3b 20 4c 45 54 2a )))) ;; LET* 3fe0: 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 0a 0a ((test-record.. 3ff0: 20 20 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 ;; we get he 4000: 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f re on "drop thro 4010: 75 67 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 ugh" - loop for 4020: 6e 65 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 next test in que 4030: 75 65 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 21 ue. ;; FIXME! 4040: 21 21 21 20 54 48 49 53 20 53 48 4f 55 4c 44 20 !!! THIS SHOULD 4050: 4e 4f 54 20 52 45 51 55 49 52 45 20 41 4e 20 45 NOT REQUIRE AN E 4060: 58 49 54 21 21 21 21 21 21 21 0a 20 20 20 20 0a XIT!!!!!!!. . 4070: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print 4080: 2d 69 6e 66 6f 20 31 20 22 41 6c 6c 20 74 65 73 -info 1 "All tes 4090: 74 73 20 6c 61 75 6e 63 68 65 64 22 29 0a 20 20 ts launched"). 40a0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep! 40b0: 20 30 2e 35 29 0a 20 20 20 20 3b 3b 20 46 49 58 0.5). ;; FIX 40c0: 4d 45 21 20 54 68 69 73 20 68 61 72 73 68 20 65 ME! This harsh e 40d0: 78 69 74 20 73 68 6f 75 6c 64 20 6e 6f 74 20 62 xit should not b 40e0: 65 20 6e 65 63 65 73 73 61 72 79 2e 2e 2e 2e 0a e necessary..... 40f0: 20 20 20 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 ;; (if (not 4100: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 28 65 78 69 *runremote*)(exi 4110: 74 29 29 20 3b 3b 20 0a 20 20 20 20 23 66 29 29 t)) ;; . #f)) 4120: 20 3b 3b 20 72 65 74 75 72 6e 20 61 20 23 66 20 ;; return a #f 4130: 61 73 20 61 20 68 69 6e 74 20 74 68 61 74 20 77 as a hint that w 4140: 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 3b 3b 20 e are done. ;; 4150: 48 65 72 65 20 77 65 20 6e 65 65 64 20 74 6f 20 Here we need to 4160: 63 68 65 63 6b 20 74 68 61 74 20 61 6c 6c 20 74 check that all t 4170: 68 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 he tests remaini 4180: 6e 67 20 74 6f 20 62 65 20 72 75 6e 20 61 72 65 ng to be run are 4190: 20 65 6c 69 67 69 62 6c 65 20 74 6f 20 72 75 6e eligible to run 41a0: 0a 20 20 3b 3b 20 61 6e 64 20 61 72 65 20 6e 6f . ;; and are no 41b0: 74 20 62 6c 6f 63 6b 65 64 20 62 79 20 66 61 69 t blocked by fai 41c0: 6c 65 64 0a 20 20 0a 0a led. ..