0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 28 64 uses server)).(d
02b0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 29 eclare (uses mt)
02c0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
02d0: 20 61 72 63 68 69 76 65 29 29 0a 3b 3b 20 28 64 archive)).;; (d
02e0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 66 69 6c eclare (uses fil
02f0: 65 64 62 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 edb))..(include
0300: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0310: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0320: 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 key_records.scm"
0330: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0340: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0350: 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 clude "run_recor
0360: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0370: 65 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e e "test_records.
0380: 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 scm")..(define (
0390: 72 75 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 runs:test-get-fu
03a0: 6c 6c 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 ll-path test).
03b0: 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
03c0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
03d0: 73 74 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a stname test)).
03e0: 09 20 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a . (itempath (db:
03f0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
0400: 74 68 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 th test))). (
0410: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 conc testname (i
0420: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 f (equal? itempa
0430: 74 68 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 th "") "" (conc
0440: 22 28 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 "(" itempath ")"
0450: 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 )))))..;; This i
0460: 73 20 74 68 65 20 2a 6e 65 77 2a 20 6d 65 74 68 s the *new* meth
0470: 6f 64 6f 6c 6f 67 79 2e 20 4f 6e 65 20 72 65 63 odology. One rec
0480: 6f 72 64 20 74 6f 20 69 6e 66 6f 72 6d 20 74 68 ord to inform th
0490: 65 6d 20 61 6e 64 20 69 6e 20 74 68 65 20 63 68 em and in the ch
04a0: 61 6f 73 2c 20 6f 72 67 61 6e 69 73 65 20 74 68 aos, organise th
04b0: 65 6d 2e 0a 3b 3b 0a 3b 3b 20 4e 4f 54 20 59 45 em..;;.;; NOT YE
04c0: 54 20 55 54 49 4c 49 5a 45 44 0a 3b 3b 0a 28 64 T UTILIZED.;;.(d
04d0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 72 65 61 efine (runs:crea
04e0: 74 65 2d 72 75 6e 2d 72 65 63 6f 72 64 29 0a 20 te-run-record).
04f0: 20 28 6c 65 74 2a 20 28 28 6d 63 6f 6e 66 69 67 (let* ((mconfig
0500: 20 20 20 20 20 20 28 69 66 20 2a 63 6f 6e 66 69 (if *confi
0510: 67 64 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 gdat*...
0520: 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 *configdat*..
0530: 09 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 . (if
0540: 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 66 6f (launch:setup-fo
0550: 72 2d 72 75 6e 29 0a 09 09 20 20 20 20 20 20 20 r-run)...
0560: 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 *configd
0570: 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 20 20 at*...
0580: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 (begin...
0590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
05a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
05b0: 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 74 RROR: Called set
05c0: 75 70 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 61 up in a non-mega
05d0: 74 65 73 74 20 61 72 65 61 2c 20 65 78 69 74 69 test area, exiti
05e0: 6e 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 ng")...
05f0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
0600: 29 29 29 29 0a 09 20 20 28 72 75 6e 72 65 63 20 )))).. (runrec
0610: 20 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 65 (runs:runre
0620: 63 2d 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 0a c-make-record)).
0630: 09 20 20 28 74 61 72 67 65 74 20 20 20 20 20 20 . (target
0640: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
0650: 2d 74 61 72 67 65 74 29 29 0a 09 20 20 28 72 75 -target)).. (ru
0660: 6e 6e 61 6d 65 20 20 20 20 20 28 6f 72 20 28 61 nname (or (a
0670: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
0680: 6e 6e 61 6d 65 22 29 0a 09 09 20 20 20 20 20 20 nname")...
0690: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
06a0: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 29 rg ":runname")))
06b0: 0a 09 20 20 28 74 65 73 74 70 61 74 74 20 20 20 .. (testpatt
06c0: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
06d0: 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a rg "-testpatt").
06e0: 09 09 20 20 20 20 20 20 20 20 20 20 20 28 61 72 .. (ar
06f0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
0700: 74 65 73 74 73 22 29 29 29 0a 09 20 20 28 6b 65 tests"))).. (ke
0710: 79 73 20 20 20 20 20 20 20 20 28 6b 65 79 73 3a ys (keys:
0720: 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 config-get-field
0730: 73 20 6d 63 6f 6e 66 69 67 29 29 0a 09 20 20 28 s mconfig)).. (
0740: 6b 65 79 76 61 6c 73 20 20 20 20 20 28 6b 65 79 keyvals (key
0750: 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c s:target->keyval
0760: 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 keys target))..
0770: 20 20 28 74 6f 70 70 61 74 68 20 20 20 20 20 2a (toppath *
0780: 74 6f 70 70 61 74 68 2a 29 0a 09 20 20 28 65 6e toppath*).. (en
0790: 76 64 61 74 20 20 20 20 20 20 6b 65 79 76 61 6c vdat keyval
07a0: 73 29 20 3b 3b 20 69 6e 69 74 69 61 6c 20 76 61 s) ;; initial va
07b0: 6c 75 65 73 20 73 74 61 72 74 20 77 69 74 68 20 lues start with
07c0: 6b 65 79 76 61 6c 73 0a 09 20 20 28 72 75 6e 63 keyvals.. (runc
07d0: 6f 6e 66 69 67 20 20 20 23 66 29 0a 09 20 20 28 onfig #f).. (
07e0: 73 65 72 76 65 72 64 61 74 20 20 20 28 69 66 20 serverdat (if
07f0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
0800: 73 65 72 76 65 72 22 29 0a 09 09 09 20 20 20 2a server").... *
0810: 72 75 6e 72 65 6d 6f 74 65 2a 0a 09 09 09 20 20 runremote*....
0820: 20 23 66 29 29 20 3b 3b 20 74 6f 20 62 65 20 75 #f)) ;; to be u
0830: 73 65 64 20 6c 61 74 65 72 0a 09 20 20 28 74 72 sed later.. (tr
0840: 61 6e 73 70 6f 72 74 20 20 20 28 6f 72 20 28 61 ansport (or (a
0850: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 72 rgs:get-arg "-tr
0860: 61 6e 73 70 6f 72 74 22 29 20 27 68 74 74 70 29 ansport") 'http)
0870: 29 0a 09 20 20 28 72 75 6e 2d 69 64 20 20 20 20 ).. (run-id
0880: 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 53 65 #f)). ;; Se
0890: 74 20 61 6c 6c 20 74 68 65 20 65 6e 76 69 72 6f t all the enviro
08a0: 6e 6d 65 6e 74 20 76 61 72 73 20 77 65 20 6b 6e nment vars we kn
08b0: 6f 77 20 73 6f 20 66 61 72 2c 20 73 74 61 72 74 ow so far, start
08c0: 20 77 69 74 68 20 6b 65 79 73 0a 20 20 20 20 28 with keys. (
08d0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
08e0: 20 28 6b 65 79 76 61 6c 29 0a 09 09 28 73 65 74 (keyval)...(set
08f0: 65 6e 76 20 28 63 61 72 20 6b 65 79 76 61 6c 29 env (car keyval)
0900: 28 63 61 64 72 20 6b 65 79 76 61 6c 29 29 29 0a (cadr keyval))).
0910: 09 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 0a . keyvals).
0920: 20 20 20 20 3b 3b 20 53 65 74 20 75 70 20 76 61 ;; Set up va
0930: 72 69 6f 75 73 20 61 6e 64 20 73 75 6e 64 72 79 rious and sundry
0940: 20 6b 6e 6f 77 6e 20 76 61 72 73 20 68 65 72 65 known vars here
0950: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
0960: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 _RUN_AREA_HOME"
0970: 74 6f 70 70 61 74 68 29 0a 20 20 20 20 28 73 65 toppath). (se
0980: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 tenv "MT_RUNNAME
0990: 22 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 " runname). (
09a0: 73 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 setenv "MT_TARGE
09b0: 54 22 20 20 74 61 72 67 65 74 29 0a 20 20 20 20 T" target).
09c0: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (setenv "MT_TEST
09d0: 53 55 49 54 45 4e 41 4d 45 22 20 28 63 6f 6d 6d SUITENAME" (comm
09e0: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
09f0: 2d 6e 61 6d 65 29 29 0a 20 20 20 20 28 73 65 74 -name)). (set
0a00: 21 20 65 6e 76 64 61 74 20 28 61 70 70 65 6e 64 ! envdat (append
0a10: 20 0a 09 09 20 20 65 6e 76 64 61 74 0a 09 09 20 ... envdat...
0a20: 20 28 6c 69 73 74 20 28 6c 69 73 74 20 22 4d 54 (list (list "MT
0a30: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 _RUN_AREA_HOME"
0a40: 74 6f 70 70 61 74 68 29 0a 09 09 09 28 6c 69 73 toppath)....(lis
0a50: 74 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 t "MT_RUNNAME"
0a60: 20 20 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 runname)...
0a70: 09 28 6c 69 73 74 20 22 4d 54 5f 54 41 52 47 45 .(list "MT_TARGE
0a80: 54 22 20 20 20 20 20 20 20 20 74 61 72 67 65 74 T" target
0a90: 29 29 29 29 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 )))). ;; Now
0aa0: 63 61 6e 20 72 65 61 64 20 74 68 65 20 72 75 6e can read the run
0ab0: 63 6f 6e 66 69 67 73 20 66 69 6c 65 0a 20 20 20 configs file.
0ac0: 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 21 20 72 ;; . (set! r
0ad0: 75 6e 63 6f 6e 66 69 67 20 28 72 65 61 64 2d 63 unconfig (read-c
0ae0: 6f 6e 66 69 67 20 28 63 6f 6e 63 20 20 2a 74 6f onfig (conc *to
0af0: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
0b00: 69 67 73 2e 63 6f 6e 66 69 67 22 29 20 23 66 20 igs.config") #f
0b10: 23 74 20 73 65 63 74 69 6f 6e 73 3a 20 28 6c 69 #t sections: (li
0b20: 73 74 20 22 64 65 66 61 75 6c 74 22 20 74 61 72 st "default" tar
0b30: 67 65 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 get))). (if (
0b40: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
0b50: 72 65 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 ref/default runc
0b60: 6f 6e 66 69 67 20 28 61 72 67 73 3a 67 65 74 2d onfig (args:get-
0b70: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
0b80: 23 66 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 #f))..(begin..
0b90: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
0ba0: 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a ERROR: [" (args:
0bb0: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
0bc0: 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 g") "] not found
0bd0: 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 in " runconfigf
0be0: 29 0a 09 20 20 28 69 66 20 64 62 20 28 73 71 6c ).. (if db (sql
0bf0: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
0c00: 62 29 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 b)).. (exit 1))
0c10: 29 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 68 61 76 ). ;; Now hav
0c20: 65 20 72 75 6e 63 6f 6e 66 69 67 73 20 64 61 74 e runconfigs dat
0c30: 61 20 6c 6f 61 64 65 64 2c 20 73 65 74 20 65 6e a loaded, set en
0c40: 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 73 0a 20 vironment vars.
0c50: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
0c60: 6d 62 64 61 20 28 73 65 63 74 69 6f 6e 29 0a 09 mbda (section)..
0c70: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
0c80: 64 61 20 28 76 61 72 76 61 6c 29 0a 09 09 09 20 da (varval)....
0c90: 20 20 20 28 73 65 74 21 20 65 6e 76 64 61 74 20 (set! envdat
0ca0: 28 61 70 70 65 6e 64 20 65 6e 76 64 61 74 20 28 (append envdat (
0cb0: 6c 69 73 74 20 76 61 72 76 61 6c 29 29 29 0a 09 list varval)))..
0cc0: 09 09 20 20 20 20 28 73 61 66 65 2d 73 65 74 65 .. (safe-sete
0cd0: 6e 76 20 28 63 61 72 20 76 61 72 76 61 6c 29 28 nv (car varval)(
0ce0: 63 61 64 72 20 76 61 72 76 61 6c 29 29 29 0a 09 cadr varval)))..
0cf0: 09 09 20 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 .. (configf:get
0d00: 2d 73 65 63 74 69 6f 6e 20 72 75 6e 63 6f 6e 66 -section runconf
0d10: 69 67 20 73 65 63 74 69 6f 6e 29 29 29 0a 09 20 ig section)))..
0d20: 20 20 20 20 20 28 6c 69 73 74 20 22 64 65 66 61 (list "defa
0d30: 75 6c 74 22 20 74 61 72 67 65 74 29 29 0a 20 20 ult" target)).
0d40: 20 20 28 76 65 63 74 6f 72 20 74 61 72 67 65 74 (vector target
0d50: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 runname testpat
0d60: 74 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 20 65 t keys keyvals e
0d70: 6e 76 64 61 74 20 6d 63 6f 6e 66 69 67 20 72 75 nvdat mconfig ru
0d80: 6e 63 6f 6e 66 69 67 20 73 65 72 76 65 72 64 61 nconfig serverda
0d90: 74 20 74 72 61 6e 73 70 6f 72 74 20 64 62 20 74 t transport db t
0da0: 6f 70 70 61 74 68 20 72 75 6e 2d 69 64 29 29 29 oppath run-id)))
0db0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
0dc0: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
0dd0: 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 23 21 6b -vars run-id #!k
0de0: 65 79 20 28 69 6e 6b 65 79 73 20 23 66 29 28 69 ey (inkeys #f)(i
0df0: 6e 72 75 6e 6e 61 6d 65 20 23 66 29 28 69 6e 6b nrunname #f)(ink
0e00: 65 79 76 61 6c 73 20 23 66 29 29 0a 20 20 28 6c eyvals #f)). (l
0e10: 65 74 2a 20 28 28 74 61 72 67 65 74 20 20 20 20 et* ((target
0e20: 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 (or (common:args
0e30: 2d 67 65 74 2d 74 61 72 67 65 74 29 0a 09 09 09 -get-target)....
0e40: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
0e50: 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 54 41 -variable "MT_TA
0e60: 52 47 45 54 22 29 29 29 0a 09 20 28 6b 65 79 73 RGET"))).. (keys
0e70: 20 20 20 20 28 69 66 20 69 6e 6b 65 79 73 20 20 (if inkeys
0e80: 20 20 69 6e 6b 65 79 73 20 20 20 20 28 72 6d 74 inkeys (rmt
0e90: 3a 67 65 74 2d 6b 65 79 73 29 29 29 0a 09 20 28 :get-keys))).. (
0ea0: 6b 65 79 76 61 6c 73 20 20 20 28 69 66 20 69 6e keyvals (if in
0eb0: 6b 65 79 76 61 6c 73 20 69 6e 6b 65 79 76 61 6c keyvals inkeyval
0ec0: 73 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e s (keys:target->
0ed0: 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 keyval keys targ
0ee0: 65 74 29 29 29 0a 09 20 28 76 61 6c 73 20 20 20 et))).. (vals
0ef0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
0f00: 65 66 2f 64 65 66 61 75 6c 74 20 2a 65 6e 76 2d ef/default *env-
0f10: 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 vars-by-run-id*
0f20: 72 75 6e 2d 69 64 20 23 66 29 29 0a 09 20 28 6c run-id #f)).. (l
0f30: 69 6e 6b 2d 74 72 65 65 20 28 63 6f 6e 66 69 67 ink-tree (config
0f40: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
0f50: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 dat* "setup" "li
0f60: 6e 6b 74 72 65 65 22 29 29 29 0a 20 20 20 20 3b nktree"))). ;
0f70: 3b 20 67 65 74 20 74 68 65 20 69 6e 66 6f 20 66 ; get the info f
0f80: 72 6f 6d 20 74 68 65 20 64 62 20 61 6e 64 20 70 rom the db and p
0f90: 75 74 20 69 74 20 69 6e 20 74 68 65 20 63 61 63 ut it in the cac
0fa0: 68 65 0a 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d he. (if link-
0fb0: 74 72 65 65 0a 09 28 73 65 74 65 6e 76 20 22 4d tree..(setenv "M
0fc0: 54 5f 4c 49 4e 4b 54 52 45 45 22 20 6c 69 6e 6b T_LINKTREE" link
0fd0: 2d 74 72 65 65 29 0a 09 28 64 65 62 75 67 3a 70 -tree)..(debug:p
0fe0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6c rint 0 "ERROR: l
0ff0: 69 6e 6b 74 72 65 65 20 6e 6f 74 20 73 65 74 2c inktree not set,
1000: 20 73 68 6f 75 6c 64 20 62 65 20 73 65 74 20 69 should be set i
1010: 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 n megatest.confi
1020: 67 20 69 6e 20 5b 73 65 74 75 70 5d 20 73 65 63 g in [setup] sec
1030: 74 69 6f 6e 2e 22 29 29 0a 20 20 20 20 28 69 66 tion.")). (if
1040: 20 28 6e 6f 74 20 76 61 6c 73 29 0a 09 28 6c 65 (not vals)..(le
1050: 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 61 73 t ((ht (make-has
1060: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 28 68 h-table))).. (h
1070: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
1080: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
1090: 69 64 2a 20 72 75 6e 2d 69 64 20 68 74 29 0a 09 id* run-id ht)..
10a0: 20 20 28 73 65 74 21 20 76 61 6c 73 20 68 74 29 (set! vals ht)
10b0: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
10c0: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a (lambda (key).
10d0: 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
10e0: 65 2d 73 65 74 21 20 76 61 6c 73 20 28 63 61 72 e-set! vals (car
10f0: 20 6b 65 79 29 20 28 63 61 64 72 20 6b 65 79 29 key) (cadr key)
1100: 29 29 0a 09 20 20 20 6b 65 79 76 61 6c 73 29 29 )).. keyvals))
1110: 29 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 ). ;; from th
1120: 65 20 63 61 63 68 65 64 20 64 61 74 61 20 73 65 e cached data se
1130: 74 20 74 68 65 20 76 61 72 73 0a 20 20 20 20 28 t the vars. (
1140: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
1150: 61 63 68 0a 20 20 20 20 20 76 61 6c 73 0a 20 20 ach. vals.
1160: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 (lambda (key
1170: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 64 65 62 val). (deb
1180: 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 ug:print 2 "sete
1190: 6e 76 20 22 20 6b 65 79 20 22 20 22 20 76 61 6c nv " key " " val
11a0: 29 0a 20 20 20 20 20 20 20 28 73 61 66 65 2d 73 ). (safe-s
11b0: 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 29 etenv key val)))
11c0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 67 . (if (not (g
11d0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
11e0: 61 72 69 61 62 6c 65 20 22 4d 54 5f 54 41 52 47 ariable "MT_TARG
11f0: 45 54 22 29 29 28 73 65 74 65 6e 76 20 22 4d 54 ET"))(setenv "MT
1200: 5f 54 41 52 47 45 54 22 20 74 61 72 67 65 74 29 _TARGET" target)
1210: 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e ). (alist->en
1220: 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 v-vars (hash-tab
1230: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
1240: 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d configdat* "env-
1250: 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a override" '())).
1260: 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 ;; Lets use
1270: 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 this as an oppor
1280: 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 tunity to put MT
1290: 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 _RUNNAME in the
12a0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 environment.
12b0: 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 20 (let ((runname
12c0: 28 69 66 20 69 6e 72 75 6e 6e 61 6d 65 20 69 6e (if inrunname in
12d0: 72 75 6e 6e 61 6d 65 20 28 72 6d 74 3a 67 65 74 runname (rmt:get
12e0: 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 -run-name-from-i
12f0: 64 20 72 75 6e 2d 69 64 29 29 29 29 0a 20 20 20 d run-id)))).
1300: 20 20 20 28 69 66 20 72 75 6e 6e 61 6d 65 0a 09 (if runname..
1310: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
1320: 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 0a NNAME" runname).
1330: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1340: 30 20 22 45 52 52 4f 52 3a 20 6e 6f 20 76 61 6c 0 "ERROR: no val
1350: 75 65 20 66 6f 72 20 72 75 6e 6e 61 6d 65 20 66 ue for runname f
1360: 6f 72 20 69 64 20 22 20 72 75 6e 2d 69 64 29 29 or id " run-id))
1370: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
1380: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
1390: 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 0a 0a 28 *toppath*)))..(
13a0: 64 65 66 69 6e 65 20 28 73 65 74 2d 69 74 65 6d define (set-item
13b0: 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d 64 61 -env-vars itemda
13c0: 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 t). (for-each (
13d0: 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 20 lambda (item)..
13e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
13f0: 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 63 t 2 "setenv " (c
1400: 61 72 20 69 74 65 6d 29 20 22 20 22 20 28 63 61 ar item) " " (ca
1410: 64 72 20 69 74 65 6d 29 29 0a 09 20 20 20 20 20 dr item))..
1420: 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 69 74 (setenv (car it
1430: 65 6d 29 20 28 63 61 64 72 20 69 74 65 6d 29 29 em) (cadr item))
1440: 29 0a 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 ).. itemdat))
1450: 0a 0a 3b 3b 20 45 76 65 72 79 20 74 69 6d 65 20 ..;; Every time
1460: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
1470: 74 73 20 69 73 20 63 61 6c 6c 65 64 20 69 6e 63 ts is called inc
1480: 72 65 6d 65 6e 74 20 74 68 65 20 64 65 6c 61 79 rement the delay
1490: 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 57 65 20 .;;.;; NOTE: We
14a0: 72 75 6e 20 74 68 69 73 20 73 65 72 76 65 72 2d run this server-
14b0: 73 69 64 65 21 21 20 44 6f 20 6e 6f 74 20 75 73 side!! Do not us
14c0: 65 20 74 68 69 73 20 67 6c 6f 62 61 6c 20 65 78 e this global ex
14d0: 63 65 70 74 20 69 6e 20 74 68 65 20 72 75 6e 73 cept in the runs
14e0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
14f0: 73 74 73 20 72 6f 75 74 69 6e 65 0a 3b 3b 0a 28 sts routine.;;.(
1500: 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d define *last-num
1510: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
1520: 30 29 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 0).(define *runs
1530: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
1540: 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 sts-count* 0).(d
1550: 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 69 efine (runs:shri
1560: 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d nk-can-run-more-
1570: 74 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 20 28 tests-count). (
1580: 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 set! *runs:can-r
1590: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f un-more-tests-co
15a0: 75 6e 74 2a 20 30 29 29 20 3b 3b 20 28 2f 20 2a unt* 0)) ;; (/ *
15b0: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
15c0: 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 32 e-tests-count* 2
15d0: 29 29 29 0a 0a 3b 3b 20 54 65 6d 70 6f 72 61 72 )))..;; Temporar
15e0: 79 20 67 6c 6f 62 61 6c 73 2e 20 4d 6f 76 65 20 y globals. Move
15f0: 74 68 65 73 65 20 69 6e 74 6f 20 74 68 65 20 6c these into the l
1600: 6f 67 69 63 20 6f 72 20 69 6e 74 6f 20 63 6f 6d ogic or into com
1610: 6d 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a mon.;;.(define *
1620: 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 seen-cant-run-te
1630: 73 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d sts* (make-hash-
1640: 74 61 62 6c 65 29 29 20 3b 3b 20 75 73 65 20 74 table)) ;; use t
1650: 6f 20 74 72 61 63 6b 20 74 65 73 74 73 20 74 68 o track tests th
1660: 61 74 20 77 65 20 73 75 73 70 65 63 74 20 63 61 at we suspect ca
1670: 6e 6e 6f 74 20 62 65 20 72 75 6e 0a 28 64 65 66 nnot be run.(def
1680: 69 6e 65 20 28 72 75 6e 73 3a 69 6e 63 2d 63 61 ine (runs:inc-ca
1690: 6e 74 2d 72 75 6e 2d 74 65 73 74 73 20 74 65 73 nt-run-tests tes
16a0: 74 6e 61 6d 65 29 0a 20 20 28 68 61 73 68 2d 74 tname). (hash-t
16b0: 61 62 6c 65 2d 73 65 74 21 20 2a 73 65 65 6e 2d able-set! *seen-
16c0: 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 cant-run-tests*
16d0: 74 65 73 74 6e 61 6d 65 0a 09 09 20 20 20 28 2b testname... (+
16e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
16f0: 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e 2d 63 /default *seen-c
1700: 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 74 ant-run-tests* t
1710: 65 73 74 6e 61 6d 65 20 30 29 20 31 29 29 29 0a estname 0) 1))).
1720: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 .(define (runs:c
1730: 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 3f an-keep-running?
1740: 20 74 65 73 74 6e 61 6d 65 20 6e 29 0a 20 20 28 testname n). (
1750: 3c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 < (hash-table-re
1760: 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e 2d f/default *seen-
1770: 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 cant-run-tests*
1780: 74 65 73 74 6e 61 6d 65 20 30 29 20 6e 29 29 0a testname 0) n)).
1790: 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 3a 64 .(define *runs:d
17a0: 65 6e 6f 69 73 65 2a 20 28 6d 61 6b 65 2d 68 61 enoise* (make-ha
17b0: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 6b 65 sh-table)) ;; ke
17c0: 79 20 3d 3e 20 6c 61 73 74 2d 74 69 6d 65 2d 72 y => last-time-r
17d0: 61 6e 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e an..(define (run
17e0: 73 3a 6c 6f 77 6e 6f 69 73 65 20 6b 65 79 20 77 s:lownoise key w
17f0: 61 69 74 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 aitval). (let (
1800: 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d (lasttime (hash-
1810: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1820: 74 20 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 65 2a t *runs:denoise*
1830: 20 6b 65 79 20 30 29 29 0a 09 28 63 75 72 72 74 key 0))..(currt
1840: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
1850: 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 onds))). (if
1860: 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 20 6c (> (- currtime l
1870: 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 61 6c asttime) waitval
1880: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 68 61 )..(begin.. (ha
1890: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 72 sh-table-set! *r
18a0: 75 6e 73 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 79 uns:denoise* key
18b0: 20 63 75 72 72 74 69 6d 65 29 0a 09 20 20 23 74 currtime).. #t
18c0: 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e )..#f)))..(defin
18d0: 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d e (runs:can-run-
18e0: 6d 6f 72 65 2d 74 65 73 74 73 20 72 75 6e 2d 69 more-tests run-i
18f0: 64 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 d jobgroup max-c
1900: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a oncurrent-jobs).
1910: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
1920: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 09 (cond. .
1930: 20 20 28 28 3e 20 2a 72 75 6e 73 3a 63 61 6e 2d ((> *runs:can-
1940: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1950: 6f 75 6e 74 2a 20 32 30 29 0a 09 09 20 20 20 28 ount* 20)... (
1960: 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 if (runs:lownois
1970: 65 20 22 77 61 69 74 69 6e 67 20 6f 6e 20 74 61 e "waiting on ta
1980: 73 6b 73 22 20 36 30 29 0a 09 09 20 20 20 20 20 sks" 60)...
1990: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
19a0: 6e 66 6f 20 32 20 22 77 61 69 74 69 6e 67 20 66 nfo 2 "waiting f
19b0: 6f 72 20 74 61 73 6b 73 20 74 6f 20 63 6f 6d 70 or tasks to comp
19c0: 6c 65 74 65 2c 20 73 6c 65 65 70 69 6e 67 20 62 lete, sleeping b
19d0: 72 69 65 66 6c 79 20 2e 2e 2e 22 29 29 0a 09 09 riefly ..."))...
19e0: 20 20 20 32 29 3b 3b 20 6f 62 76 69 6f 75 73 6c 2);; obviousl
19f0: 79 20 68 61 76 65 6e 27 74 20 68 61 64 20 61 6e y haven't had an
1a00: 79 20 77 6f 72 6b 20 74 6f 20 64 6f 20 66 6f 72 y work to do for
1a10: 20 61 20 77 68 69 6c 65 0a 20 20 20 20 20 20 20 a while.
1a20: 20 09 20 20 28 65 6c 73 65 20 30 29 29 29 0a 20 . (else 0))).
1a30: 20 28 6c 65 74 2a 20 28 28 6e 75 6d 2d 72 75 6e (let* ((num-run
1a40: 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 20 20 ning
1a50: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d (rmt:get-count-
1a60: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 tests-running ru
1a70: 6e 2d 69 64 29 29 0a 09 20 28 6e 75 6d 2d 72 75 n-id)).. (num-ru
1a80: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
1a90: 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 p (rmt:get-count
1aa0: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 -tests-running-i
1ab0: 6e 2d 6a 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 n-jobgroup run-i
1ac0: 64 20 6a 6f 62 67 72 6f 75 70 29 29 0a 09 20 28 d jobgroup)).. (
1ad0: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 job-group-limit
1ae0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6a (let ((j
1af0: 6f 62 67 2d 63 6f 75 6e 74 20 28 63 6f 6e 66 69 obg-count (confi
1b00: 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 g-lookup *config
1b10: 64 61 74 2a 20 22 6a 6f 62 67 72 6f 75 70 73 22 dat* "jobgroups"
1b20: 20 6a 6f 62 67 72 6f 75 70 29 29 29 0a 09 09 09 jobgroup)))....
1b30: 09 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 . (if (string
1b40: 3f 20 6a 6f 62 67 2d 63 6f 75 6e 74 29 0a 09 09 ? jobg-count)...
1b50: 09 09 09 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ...(string->numb
1b60: 65 72 20 6a 6f 62 67 2d 63 6f 75 6e 74 29 0a 09 er jobg-count)..
1b70: 09 09 09 09 6a 6f 62 67 2d 63 6f 75 6e 74 29 29 ....jobg-count))
1b80: 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 2b )). (if (> (+
1b90: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d num-running num
1ba0: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1bb0: 72 6f 75 70 29 20 30 29 0a 09 28 73 65 74 21 20 roup) 0)..(set!
1bc0: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
1bd0: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
1be0: 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e (+ *runs:can-run
1bf0: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
1c00: 74 2a 20 31 29 29 29 0a 20 20 20 20 28 69 66 20 t* 1))). (if
1c10: 28 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d (not (eq? *last-
1c20: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 num-running-test
1c30: 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 s* num-running))
1c40: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
1c50: 75 67 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d ug:print 2 "max-
1c60: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a concurrent-jobs:
1c70: 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e " max-concurren
1c80: 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 t-jobs ", num-ru
1c90: 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e nning: " num-run
1ca0: 6e 69 6e 67 29 0a 09 20 20 28 73 65 74 21 20 2a ning).. (set! *
1cb0: 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 last-num-running
1cc0: 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e -tests* num-runn
1cd0: 69 6e 67 29 29 29 0a 20 20 20 20 28 69 66 20 28 ing))). (if (
1ce0: 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 not (eq? 0 *glob
1cf0: 61 6c 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a alexitstatus*)).
1d00: 09 28 6c 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 .(list #f num-ru
1d10: 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e nning num-runnin
1d20: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 g-in-jobgroup ma
1d30: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1d40: 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 s job-group-limi
1d50: 74 29 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e t)..(let ((can-n
1d60: 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e ot-run-more (con
1d70: 64 0a 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 d..... ;; if max
1d80: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1d90: 20 69 73 20 73 65 74 20 61 6e 64 20 74 68 65 20 is set and the
1da0: 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 number running i
1db0: 73 20 67 72 65 61 74 65 72 20 0a 09 09 09 09 20 s greater .....
1dc0: 3b 3b 20 74 68 61 6e 20 69 74 20 74 68 61 6e 20 ;; than it than
1dd0: 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 cannot run more
1de0: 6a 6f 62 73 0a 09 09 09 09 20 28 28 61 6e 64 20 jobs..... ((and
1df0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1e00: 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e obs (>= num-runn
1e10: 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 ing max-concurre
1e20: 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 nt-jobs)).....
1e30: 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 (if (runs:lownoi
1e40: 73 65 20 22 6d 63 6a 20 6d 73 67 22 20 36 30 29 se "mcj msg" 60)
1e50: 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
1e60: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
1e70: 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 NG: Max running
1e80: 6a 6f 62 73 20 65 78 63 65 65 64 65 64 2c 20 63 jobs exceeded, c
1e90: 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 urrent number ru
1ea0: 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e nning: " num-run
1eb0: 6e 69 6e 67 20 0a 09 09 09 09 09 09 20 20 20 22 ning ....... "
1ec0: 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 , max_concurrent
1ed0: 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e _jobs: " max-con
1ee0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 current-jobs))..
1ef0: 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 3b 3b ... #t)..... ;;
1f00: 20 69 66 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 if job-group-li
1f10: 6d 69 74 20 69 73 20 73 65 74 20 61 6e 64 20 6e mit is set and n
1f20: 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 69 6e umber of jobs in
1f30: 20 74 68 65 20 67 72 6f 75 70 20 69 73 20 67 72 the group is gr
1f40: 65 61 74 65 72 0a 09 09 09 09 20 3b 3b 20 74 68 eater..... ;; th
1f50: 61 6e 20 74 68 65 20 6c 69 6d 69 74 20 74 68 65 an the limit the
1f60: 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 n cannot run mor
1f70: 65 20 6a 6f 62 73 20 6f 66 20 74 68 69 73 20 6b e jobs of this k
1f80: 69 6e 64 0a 09 09 09 09 20 28 28 61 6e 64 20 6a ind..... ((and j
1f90: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 0a 09 ob-group-limit..
1fa0: 09 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 ... (>= nu
1fb0: 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 m-running-in-job
1fc0: 67 72 6f 75 70 20 6a 6f 62 2d 67 72 6f 75 70 2d group job-group-
1fd0: 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 20 28 69 limit))..... (i
1fe0: 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 f (runs:lownoise
1ff0: 20 28 63 6f 6e 63 20 22 6d 61 78 6a 6f 62 67 72 (conc "maxjobgr
2000: 6f 75 70 20 22 20 6a 6f 62 67 72 6f 75 70 29 20 oup " jobgroup)
2010: 36 30 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 60)..... (d
2020: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 ebug:print 1 "WA
2030: 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 72 20 6f 66 RNING: number of
2040: 20 6a 6f 62 73 20 22 20 6e 75 6d 2d 72 75 6e 6e jobs " num-runn
2050: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
2060: 0a 09 09 09 09 09 09 20 20 20 22 20 69 6e 20 6a ....... " in j
2070: 6f 62 67 72 6f 75 70 20 5c 22 22 20 6a 6f 62 67 obgroup \"" jobg
2080: 72 6f 75 70 20 22 5c 22 20 65 78 63 65 65 64 73 roup "\" exceeds
2090: 20 6c 69 6d 69 74 20 6f 66 20 22 20 6a 6f 62 2d limit of " job-
20a0: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 group-limit))...
20b0: 09 09 20 20 23 74 29 0a 09 09 09 09 20 28 65 6c .. #t)..... (el
20c0: 73 65 20 23 66 29 29 29 29 0a 09 20 20 28 6c 69 se #f)))).. (li
20d0: 73 74 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d st (not can-not-
20e0: 72 75 6e 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 75 run-more) num-ru
20f0: 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e nning num-runnin
2100: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 g-in-jobgroup ma
2110: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
2120: 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 s job-group-limi
2130: 74 29 29 29 29 29 0a 0a 0a 3b 3b 20 20 74 65 73 t)))))...;; tes
2140: 74 2d 6e 61 6d 65 73 3a 20 43 6f 6d 6d 61 20 73 t-names: Comma s
2150: 65 70 61 72 61 74 65 64 20 70 61 74 74 65 72 6e eparated pattern
2160: 73 20 73 61 6d 65 20 61 73 20 74 65 73 74 2d 70 s same as test-p
2170: 61 74 74 73 20 62 75 74 20 75 73 65 64 20 69 6e atts but used in
2180: 20 73 65 6c 65 63 74 69 6f 6e 20 0a 3b 3b 20 20 selection .;;
2190: 20 20 20 20 20 20 20 20 20 20 20 20 6f 66 20 74 of t
21a0: 65 73 74 73 20 74 6f 20 72 75 6e 2e 20 54 68 65 ests to run. The
21b0: 20 69 74 65 6d 20 70 6f 72 74 69 6f 6e 73 20 61 item portions a
21c0: 72 65 20 6e 6f 74 20 72 65 73 70 65 63 74 65 64 re not respected
21d0: 2e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ..;;
21e0: 20 20 46 49 58 4d 45 3a 20 65 72 72 6f 72 20 6f FIXME: error o
21f0: 75 74 20 69 66 20 2f 70 61 74 74 20 73 70 65 63 ut if /patt spec
2200: 69 66 69 65 64 0a 3b 3b 20 20 20 20 20 20 20 20 ified.;;
2210: 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 72 75 .(define (ru
2220: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 61 72 ns:run-tests tar
2230: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
2240: 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c 61 67 -patts user flag
2250: 73 20 23 21 6b 65 79 20 28 72 75 6e 2d 63 6f 75 s #!key (run-cou
2260: 6e 74 20 33 29 29 20 3b 3b 20 74 65 73 74 2d 6e nt 3)) ;; test-n
2270: 61 6d 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 6b ames. (let* ((k
2280: 65 79 73 20 20 20 20 20 20 20 20 20 20 20 20 20 eys
2290: 20 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 (keys:config-g
22a0: 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 et-fields *confi
22b0: 67 64 61 74 2a 29 29 0a 09 20 28 6b 65 79 76 61 gdat*)).. (keyva
22c0: 6c 73 20 20 20 20 20 20 20 20 20 20 20 20 28 6b ls (k
22d0: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
22e0: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
22f0: 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 .. (run-id
2300: 20 20 20 20 20 20 20 28 72 6d 74 3a 72 65 67 69 (rmt:regi
2310: 73 74 65 72 2d 72 75 6e 20 6b 65 79 76 61 6c 73 ster-run keyvals
2320: 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 runname "new" "
2330: 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b 3b 20 n/a" user)) ;;
2340: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 test-name)))..
2350: 28 64 65 66 65 72 72 65 64 20 20 20 20 20 20 20 (deferred
2360: 20 20 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 '()) ;; delay
2370: 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 running these s
2380: 69 6e 63 65 20 74 68 65 79 20 68 61 76 65 20 61 ince they have a
2390: 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 waiton clause..
23a0: 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 20 (runconfigf
23b0: 20 20 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 (conc *top
23c0: 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 path* "/runconfi
23d0: 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 gs.config")).. (
23e0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 20 20 20 test-records
23f0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
2400: 62 6c 65 29 29 0a 09 20 3b 3b 20 6e 65 65 64 20 ble)).. ;; need
2410: 74 6f 20 70 72 6f 63 65 73 73 20 72 75 6e 63 6f to process runco
2420: 6e 66 69 67 73 20 62 65 66 6f 72 65 20 67 65 6e nfigs before gen
2430: 65 72 61 74 69 6e 67 20 74 68 65 73 65 20 6c 69 erating these li
2440: 73 74 73 0a 09 20 28 61 6c 6c 2d 74 65 73 74 73 sts.. (all-tests
2450: 2d 72 65 67 69 73 74 72 79 20 23 66 29 20 20 3b -registry #f) ;
2460: 3b 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c ; (tests:get-all
2470: 29 29 20 3b 3b 20 28 74 65 73 74 73 3a 67 65 74 )) ;; (tests:get
2480: 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 28 6d 61 -valid-tests (ma
2490: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 20 74 ke-hash-table) t
24a0: 65 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 29 est-search-path)
24b0: 29 20 3b 3b 20 61 6c 6c 20 76 61 6c 69 64 20 74 ) ;; all valid t
24c0: 65 73 74 73 20 74 6f 20 63 68 65 63 6b 20 77 61 ests to check wa
24d0: 69 74 6f 6e 20 6e 61 6d 65 73 0a 09 20 28 61 6c iton names.. (al
24e0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 l-test-names
24f0: 20 23 66 29 20 20 3b 3b 20 28 68 61 73 68 2d 74 #f) ;; (hash-t
2500: 61 62 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 65 able-keys all-te
2510: 73 74 73 2d 72 65 67 69 73 74 72 79 29 29 0a 09 sts-registry))..
2520: 20 28 74 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 (test-names
2530: 20 20 20 20 20 23 66 29 20 20 3b 3b 20 28 74 65 #f) ;; (te
2540: 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d sts:filter-test-
2550: 6e 61 6d 65 73 20 61 6c 6c 2d 74 65 73 74 2d 6e names all-test-n
2560: 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 ames test-patts)
2570: 29 0a 09 20 28 72 65 71 75 69 72 65 64 2d 74 65 ).. (required-te
2580: 73 74 73 20 20 20 20 20 23 66 29 20 20 3b 3b 20 sts #f) ;;
2590: 50 75 74 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 Put fully qualif
25a0: 69 65 64 20 74 65 73 74 2f 74 65 73 74 70 61 74 ied test/testpat
25b0: 68 20 6e 61 6d 65 73 20 69 6e 20 74 68 69 73 20 h names in this
25c0: 6c 69 73 74 20 74 6f 20 62 65 20 64 6f 6e 65 0a list to be done.
25d0: 09 20 28 74 61 73 6b 2d 6b 65 79 20 20 20 20 20 . (task-key
25e0: 20 20 20 20 20 20 28 63 6f 6e 63 20 28 68 61 73 (conc (has
25f0: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 h-table->alist f
2600: 6c 61 67 73 29 20 22 20 22 20 28 67 65 74 2d 68 lags) " " (get-h
2610: 6f 73 74 2d 6e 61 6d 65 29 20 22 20 22 20 28 63 ost-name) " " (c
2620: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
2630: 64 29 29 29 0a 09 20 28 74 64 62 64 61 74 20 20 d))).. (tdbdat
2640: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 73 6b (task
2650: 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 0a 20 20 s:open-db)))..
2660: 20 20 28 69 66 20 28 74 61 73 6b 73 3a 6e 65 65 (if (tasks:nee
2670: 64 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 d-server run-id)
2680: 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 (tasks:start-and
2690: 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 -wait-for-server
26a0: 20 74 64 62 64 61 74 20 72 75 6e 2d 69 64 20 31 tdbdat run-id 1
26b0: 30 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 28 28 0)).. (let ((
26c0: 73 69 67 68 61 6e 64 20 28 6c 61 6d 62 64 61 20 sighand (lambda
26d0: 28 73 69 67 6e 75 6d 29 0a 09 09 20 20 20 20 20 (signum)...
26e0: 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 ;; (signal-mask!
26f0: 20 73 69 67 6e 75 6d 29 20 3b 3b 20 74 6f 20 6d signum) ;; to m
2700: 61 73 6b 20 6f 72 20 6e 6f 74 3f 20 73 65 65 6d ask or not? seem
2710: 73 20 74 6f 20 63 61 75 73 65 20 69 73 73 75 65 s to cause issue
2720: 73 20 69 6e 20 65 78 69 74 69 6e 67 0a 09 09 20 s in exiting...
2730: 20 20 20 20 28 69 66 20 28 65 71 3f 20 73 69 67 (if (eq? sig
2740: 6e 75 6d 20 73 69 67 6e 61 6c 2f 73 74 6f 70 29 num signal/stop)
2750: 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
2760: 74 20 30 20 22 45 52 52 4f 52 3a 20 61 74 74 65 t 0 "ERROR: atte
2770: 6d 70 74 20 74 6f 20 53 54 4f 50 20 70 72 6f 63 mpt to STOP proc
2780: 65 73 73 2e 20 45 78 69 74 69 6e 67 2e 22 29 29 ess. Exiting."))
2790: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 2a 74 ... (set! *t
27a0: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 ime-to-exit* #t)
27b0: 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ... (print "
27c0: 52 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c 20 Received signal
27d0: 22 20 73 69 67 6e 75 6d 20 22 2c 20 63 6c 65 61 " signum ", clea
27e0: 6e 69 6e 67 20 75 70 20 62 65 66 6f 72 65 20 65 ning up before e
27f0: 78 69 74 2e 20 50 6c 65 61 73 65 20 77 61 69 74 xit. Please wait
2800: 2e 2e 2e 22 29 0a 09 09 20 20 20 20 20 28 6c 65 ...")... (le
2810: 74 20 28 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 t ((th1 (make-th
2820: 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a read (lambda ().
2830: 09 09 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 ..... (let
2840: 20 28 28 74 64 62 64 61 74 20 28 74 61 73 6b 73 ((tdbdat (tasks
2850: 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 09 09 09 09 :open-db))).....
2860: 09 09 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 .. (rmt:tasks-se
2870: 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 t-state-given-pa
2880: 72 61 6d 2d 6b 65 79 20 74 61 73 6b 2d 6b 65 79 ram-key task-key
2890: 20 22 6b 69 6c 6c 65 64 22 29 29 0a 09 09 09 09 "killed")).....
28a0: 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
28b0: 4b 69 6c 6c 65 64 20 62 79 20 73 69 67 6e 61 6c Killed by signal
28c0: 20 22 20 73 69 67 6e 75 6d 20 22 2e 20 45 78 69 " signum ". Exi
28d0: 74 69 6e 67 22 29 0a 09 09 09 09 09 20 20 20 20 ting")......
28e0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
28f0: 21 20 33 29 0a 09 09 09 09 09 20 20 20 20 20 20 ! 3)......
2900: 20 28 65 78 69 74 29 29 29 29 0a 09 09 09 20 20 (exit))))....
2910: 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 (th2 (make-thre
2920: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
2930: 09 09 09 20 20 20 20 20 20 20 28 74 68 72 65 61 ... (threa
2940: 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 09 09 09 d-sleep! 5).....
2950: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
2960: 72 69 6e 74 20 30 20 22 44 6f 6e 65 22 29 0a 09 rint 0 "Done")..
2970: 09 09 09 09 20 20 20 20 20 20 20 28 65 78 69 74 .... (exit
2980: 20 34 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 4)))))...
2990: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
29a0: 74 68 32 29 0a 09 09 20 20 20 20 20 20 20 28 74 th2)... (t
29b0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 hread-start! th1
29c0: 29 0a 09 09 20 20 20 20 20 20 20 28 74 68 72 65 )... (thre
29d0: 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 29 ad-join! th2))))
29e0: 29 0a 20 20 20 20 20 20 28 73 65 74 2d 73 69 67 ). (set-sig
29f0: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
2a00: 6e 61 6c 2f 69 6e 74 20 73 69 67 68 61 6e 64 29 nal/int sighand)
2a10: 0a 20 20 20 20 20 20 28 73 65 74 2d 73 69 67 6e . (set-sign
2a20: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
2a30: 61 6c 2f 74 65 72 6d 20 73 69 67 68 61 6e 64 29 al/term sighand)
2a40: 0a 20 20 20 20 20 20 28 73 65 74 2d 73 69 67 6e . (set-sign
2a50: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
2a60: 61 6c 2f 73 74 6f 70 20 73 69 67 68 61 6e 64 29 al/stop sighand)
2a70: 29 0a 0a 20 20 20 20 3b 3b 20 72 65 67 69 73 74 ).. ;; regist
2a80: 65 72 20 74 68 69 73 20 72 75 6e 20 69 6e 20 6d er this run in m
2a90: 6f 6e 69 74 6f 72 2e 64 62 0a 20 20 20 20 28 72 onitor.db. (r
2aa0: 6d 74 3a 74 61 73 6b 73 2d 61 64 64 20 22 72 75 mt:tasks-add "ru
2ab0: 6e 2d 74 65 73 74 73 22 20 75 73 65 72 20 74 61 n-tests" user ta
2ac0: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 rget runname tes
2ad0: 74 2d 70 61 74 74 73 20 74 61 73 6b 2d 6b 65 79 t-patts task-key
2ae0: 29 20 3b 3b 20 70 61 72 61 6d 73 29 0a 20 20 20 ) ;; params).
2af0: 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 74 2d (rmt:tasks-set-
2b00: 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 state-given-para
2b10: 6d 2d 6b 65 79 20 74 61 73 6b 2d 6b 65 79 20 22 m-key task-key "
2b20: 72 75 6e 6e 69 6e 67 22 29 0a 20 20 20 20 28 72 running"). (r
2b30: 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 73 74 uns:set-megatest
2b40: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
2b50: 20 69 6e 6b 65 79 73 3a 20 6b 65 79 73 20 69 6e inkeys: keys in
2b60: 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d 65 runname: runname
2b70: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
2b80: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
2b90: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
2ba0: 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d s. (if (file-
2bb0: 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 exists? runconfi
2bc0: 67 66 29 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d gf)..(setup-env-
2bd0: 64 65 66 61 75 6c 74 73 20 72 75 6e 63 6f 6e 66 defaults runconf
2be0: 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 igf run-id *alre
2bf0: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
2c00: 69 67 2d 69 6e 66 6f 2a 20 6b 65 79 76 61 6c 73 ig-info* keyvals
2c10: 20 74 61 72 67 65 74 29 0a 09 28 64 65 62 75 67 target)..(debug
2c20: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
2c30: 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 G: You do not ha
2c40: 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 ve a run config
2c50: 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 file: " runconfi
2c60: 67 66 29 29 0a 0a 20 20 20 20 3b 3b 20 4e 6f 77 gf)).. ;; Now
2c70: 20 67 65 6e 65 72 61 74 65 20 61 6c 6c 20 74 68 generate all th
2c80: 65 20 74 65 73 74 73 20 6c 69 73 74 73 0a 20 20 e tests lists.
2c90: 20 20 28 73 65 74 21 20 61 6c 6c 2d 74 65 73 74 (set! all-test
2ca0: 73 2d 72 65 67 69 73 74 72 79 20 28 74 65 73 74 s-registry (test
2cb0: 73 3a 67 65 74 2d 61 6c 6c 29 29 0a 20 20 20 20 s:get-all)).
2cc0: 28 73 65 74 21 20 61 6c 6c 2d 74 65 73 74 2d 6e (set! all-test-n
2cd0: 61 6d 65 73 20 20 20 20 20 28 68 61 73 68 2d 74 ames (hash-t
2ce0: 61 62 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 65 able-keys all-te
2cf0: 73 74 73 2d 72 65 67 69 73 74 72 79 29 29 0a 20 sts-registry)).
2d00: 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 (set! test-na
2d10: 6d 65 73 20 20 20 20 20 20 20 20 20 28 74 65 73 mes (tes
2d20: 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e ts:filter-test-n
2d30: 61 6d 65 73 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 ames all-test-na
2d40: 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 29 mes test-patts))
2d50: 0a 0a 20 20 20 20 3b 3b 20 49 20 74 68 69 6e 6b .. ;; I think
2d60: 20 73 65 65 64 69 6e 67 20 72 65 71 75 69 72 65 seeding require
2d70: 64 2d 74 65 73 74 73 20 77 69 74 68 20 61 6c 6c d-tests with all
2d80: 20 74 65 73 74 2d 6e 61 6d 65 73 20 6d 61 6b 65 test-names make
2d90: 73 20 73 65 6e 73 65 20 62 75 74 20 6c 61 63 6b s sense but lack
2da0: 20 61 6e 61 6c 79 73 69 73 20 74 6f 20 62 61 63 analysis to bac
2db0: 6b 20 74 68 61 74 20 75 70 2e 0a 0a 20 20 20 20 k that up...
2dc0: 3b 3b 20 4e 45 57 20 53 54 52 41 54 45 47 59 20 ;; NEW STRATEGY
2dd0: 48 45 52 45 3a 0a 20 20 20 20 3b 3b 20 31 2e 20 HERE:. ;; 1.
2de0: 66 69 6c 6c 20 72 65 71 75 69 72 65 64 20 74 65 fill required te
2df0: 73 74 73 20 77 69 74 68 20 74 65 73 74 2d 70 61 sts with test-pa
2e00: 74 74 73 0a 20 20 20 20 3b 3b 20 32 2e 20 73 63 tts. ;; 2. sc
2e10: 61 6e 20 74 65 73 74 63 6f 6e 66 69 67 73 20 61 an testconfigs a
2e20: 6e 64 20 69 66 20 77 61 69 74 6f 6e 73 2c 20 69 nd if waitons, i
2e30: 74 65 6d 77 61 69 74 2c 20 69 74 65 6d 70 61 74 temwait, itempat
2e40: 74 20 63 61 6c 63 20 70 72 69 6f 72 20 74 65 73 t calc prior tes
2e50: 74 20 74 65 73 74 2d 70 61 74 74 0a 20 20 20 20 t test-patt.
2e60: 3b 3b 20 33 2e 20 72 65 70 65 61 74 20 75 6e 74 ;; 3. repeat unt
2e70: 69 6c 20 61 6c 6c 20 64 65 70 73 20 70 72 6f 70 il all deps prop
2e80: 61 67 61 74 65 64 0a 20 20 20 20 0a 20 20 20 20 agated. .
2e90: 3b 3b 20 61 6e 79 20 74 65 73 74 73 20 77 69 74 ;; any tests wit
2ea0: 68 20 64 69 72 65 63 74 20 6d 65 6e 74 69 6f 6e h direct mention
2eb0: 20 69 6e 20 74 65 73 74 2d 70 61 74 74 73 20 63 in test-patts c
2ec0: 61 6e 20 62 65 20 61 64 64 65 64 20 74 6f 20 72 an be added to r
2ed0: 65 71 75 69 72 65 64 0a 20 20 20 20 3b 3b 0a 20 equired. ;;.
2ee0: 20 20 20 28 73 65 74 21 20 72 65 71 75 69 72 65 (set! require
2ef0: 64 2d 74 65 73 74 73 20 20 20 20 20 28 6c 73 65 d-tests (lse
2f00: 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 65 t-intersection e
2f10: 71 75 61 6c 3f 20 28 73 74 72 69 6e 67 2d 73 70 qual? (string-sp
2f20: 6c 69 74 20 74 65 73 74 2d 70 61 74 74 73 20 22 lit test-patts "
2f30: 2c 22 29 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d ,") all-test-nam
2f40: 65 73 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 74 es)). ;; (set
2f50: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
2f60: 20 20 20 20 20 28 6c 73 65 74 2d 69 6e 74 65 72 (lset-inter
2f70: 73 65 63 74 69 6f 6e 20 65 71 75 61 6c 3f 20 74 section equal? t
2f80: 65 73 74 2d 6e 61 6d 65 73 20 61 6c 6c 2d 74 65 est-names all-te
2f90: 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 0a st-names)). .
2fa0: 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 ;; look up a
2fb0: 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e ll tests matchin
2fc0: 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 61 g the comma sepa
2fd0: 72 61 74 65 64 20 6c 69 73 74 20 6f 66 20 67 6c rated list of gl
2fe0: 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 65 obs in. ;; te
2ff0: 73 74 2d 70 61 74 74 73 20 28 75 73 69 6e 67 20 st-patts (using
3000: 25 20 61 73 20 77 69 6c 64 63 61 72 64 29 0a 0a % as wildcard)..
3010: 20 20 20 20 3b 3b 20 28 73 65 74 21 20 74 65 73 ;; (set! tes
3020: 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 2d t-names (delete-
3030: 64 75 70 6c 69 63 61 74 65 73 20 28 74 65 73 74 duplicates (test
3040: 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 s:get-valid-test
3050: 73 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 73 74 s *toppath* test
3060: 2d 70 61 74 74 73 29 29 29 0a 20 20 20 20 28 64 -patts))). (d
3070: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3080: 30 20 22 74 65 73 74 73 20 73 65 61 72 63 68 20 0 "tests search
3090: 70 61 74 68 3a 20 22 20 28 73 74 72 69 6e 67 2d path: " (string-
30a0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 74 65 73 intersperse (tes
30b0: 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 ts:get-tests-sea
30c0: 72 63 68 2d 70 61 74 68 20 2a 63 6f 6e 66 69 67 rch-path *config
30d0: 64 61 74 2a 29 20 22 20 22 29 29 0a 20 20 20 20 dat*) " ")).
30e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
30f0: 6f 20 30 20 22 61 6c 6c 20 74 65 73 74 73 3a 20 o 0 "all tests:
3100: 20 20 20 20 20 20 20 20 22 20 28 73 74 72 69 6e " (strin
3110: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 73 g-intersperse (s
3120: 6f 72 74 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d ort all-test-nam
3130: 65 73 20 73 74 72 69 6e 67 3c 29 20 22 20 22 29 es string<) " ")
3140: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
3150: 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 20 nt-info 0 "test
3160: 6e 61 6d 65 73 3a 20 20 20 20 20 20 20 20 22 20 names: "
3170: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
3180: 72 73 65 20 28 73 6f 72 74 20 74 65 73 74 2d 6e rse (sort test-n
3190: 61 6d 65 73 20 73 74 72 69 6e 67 3c 29 20 22 20 ames string<) "
31a0: 22 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ")). (debug:p
31b0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 72 65 71 rint-info 0 "req
31c0: 75 69 72 65 64 20 74 65 73 74 73 3a 20 20 20 20 uired tests:
31d0: 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 " (string-inters
31e0: 70 65 72 73 65 20 28 73 6f 72 74 20 72 65 71 75 perse (sort requ
31f0: 69 72 65 64 2d 74 65 73 74 73 20 73 74 72 69 6e ired-tests strin
3200: 67 3c 29 20 22 20 22 29 29 0a 0a 20 20 20 20 3b g<) " ")).. ;
3210: 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 70 ; on the first p
3220: 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 ass or call to r
3230: 75 6e 2d 74 65 73 74 73 20 73 65 74 20 46 41 49 un-tests set FAI
3240: 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 LS to NOT_STARTE
3250: 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 D if. ;; -kee
3260: 70 67 6f 69 6e 67 20 69 73 20 73 70 65 63 69 66 pgoing is specif
3270: 69 65 64 0a 20 20 20 20 28 69 66 20 28 65 71 3f ied. (if (eq?
3280: 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 28 *passnum* 0)..(
3290: 62 65 67 69 6e 0a 09 20 20 3b 3b 20 49 73 20 74 begin.. ;; Is t
32a0: 68 69 73 20 73 74 69 6c 6c 20 6e 65 63 65 73 73 his still necess
32b0: 61 72 79 3f 20 49 20 74 68 69 6e 6b 20 6e 6f 74 ary? I think not
32c0: 2e 20 55 6e 72 65 61 63 68 61 62 6c 65 20 74 65 . Unreachable te
32d0: 73 74 73 20 61 72 65 20 6d 61 72 6b 65 64 20 61 sts are marked a
32e0: 73 20 73 75 63 68 20 61 6e 64 20 0a 09 20 20 3b s such and .. ;
32f0: 3b 20 73 68 6f 75 6c 64 20 6e 6f 74 20 63 61 75 ; should not cau
3300: 73 65 20 70 72 6f 62 6c 65 6d 73 20 68 65 72 65 se problems here
3310: 2e 0a 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 68 61 ... ;;.. ;; ha
3320: 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 ve to delete tes
3330: 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 t records where
3340: 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 NOT_STARTED sinc
3350: 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 e they can cause
3360: 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a -keepgoing to .
3370: 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 . ;; get stuck
3380: 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 due to becoming
3390: 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f inaccessible fro
33a0: 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e m a failed test.
33b0: 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 I.e. if test B
33c0: 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f depends .. ;; o
33d0: 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 73 n test A but tes
33e0: 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 20 t B reached the
33f0: 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 point on being r
3400: 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 egistered as NOT
3410: 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 _STARTED and tes
3420: 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 t.. ;; A failed
3430: 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e for some reason
3440: 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 then on re-run
3450: 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 using -keepgoing
3460: 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 the run can nev
3470: 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 er complete...
3480: 3b 3b 0a 09 20 20 3b 3b 20 28 72 6d 74 3a 67 65 ;;.. ;; (rmt:ge
3490: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 64 65 6c 65 neral-call 'dele
34a0: 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 te-tests-in-stat
34b0: 65 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 e run-id "NOT_ST
34c0: 41 52 54 45 44 22 29 0a 09 20 20 0a 09 20 20 3b ARTED").. .. ;
34d0: 3b 20 4e 6f 77 20 63 6f 6e 76 65 72 74 20 61 6e ; Now convert an
34e0: 79 74 68 69 6e 67 20 69 6e 20 61 6c 6c 6f 77 2d ything in allow-
34f0: 61 75 74 6f 2d 72 65 72 75 6e 20 74 6f 20 4e 4f auto-rerun to NO
3500: 54 5f 53 54 41 52 54 45 44 0a 09 20 20 3b 3b 0a T_STARTED.. ;;.
3510: 09 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 . (for-each (la
3520: 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 20 mbda (state)...
3530: 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d 74 65 (rmt:set-te
3540: 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 sts-state-status
3550: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
3560: 65 73 20 73 74 61 74 65 20 23 66 20 22 4e 4f 54 es state #f "NOT
3570: 5f 53 54 41 52 54 45 44 22 20 73 74 61 74 65 29 _STARTED" state)
3580: 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d )... (string-
3590: 73 70 6c 69 74 20 28 6f 72 20 28 63 6f 6e 66 69 split (or (confi
35a0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
35b0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 61 gdat* "setup" "a
35c0: 6c 6c 6f 77 2d 61 75 74 6f 2d 72 65 72 75 6e 22 llow-auto-rerun"
35d0: 29 20 22 22 29 29 29 29 29 0a 0a 20 20 20 20 3b ) ""))))).. ;
35e0: 3b 20 45 6e 73 75 72 65 20 61 6c 6c 20 74 65 73 ; Ensure all tes
35f0: 74 73 20 61 72 65 20 72 65 67 69 73 74 65 72 65 ts are registere
3600: 64 20 69 6e 20 74 68 65 20 74 65 73 74 5f 6d 65 d in the test_me
3610: 74 61 20 74 61 62 6c 65 0a 20 20 20 20 28 72 75 ta table. (ru
3620: 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 ns:update-all-te
3630: 73 74 5f 6d 65 74 61 20 23 66 29 0a 0a 20 20 20 st_meta #f)..
3640: 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f 6e 2d ;; now add non-
3650: 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 65 6e directly referen
3660: 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 65 73 ced dependencies
3670: 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 0a 20 (i.e. waiton).
3680: 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;===========
3690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 ===========.
36d0: 3b 3b 20 72 65 66 61 63 74 6f 72 69 6e 67 20 74 ;; refactoring t
36e0: 68 69 73 20 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 his block into t
36f0: 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 ests:get-full-da
3700: 74 61 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b ta. ;;. ;;
3710: 20 57 68 61 74 20 68 61 70 70 65 6e 64 65 64 2c What happended,
3720: 20 74 68 69 73 20 63 6f 64 65 20 69 73 20 6e 6f this code is no
3730: 77 20 64 75 70 6c 69 63 61 74 65 64 20 69 6e 20 w duplicated in
3740: 74 65 73 74 73 21 3f 0a 20 20 20 20 3b 3b 0a 20 tests!?. ;;.
3750: 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;===========
3760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 ===========.
37a0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
37b0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c test-names))..(l
37c0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
37d0: 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ar test-names)).
37e0: 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 74 .. (tal (cdr t
37f0: 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 est-names)))
3800: 20 20 20 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d ;; 'return-
3810: 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 20 procs tells the
3820: 63 6f 6e 66 69 67 20 72 65 61 64 65 72 20 74 6f config reader to
3830: 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 prep running sy
3840: 73 74 65 6d 20 62 75 74 20 72 65 74 75 72 6e 20 stem but return
3850: 61 20 70 72 6f 63 0a 09 20 20 28 63 68 61 6e 67 a proc.. (chang
3860: 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 e-directory *top
3870: 70 61 74 68 2a 29 20 3b 3b 20 50 4c 45 41 53 45 path*) ;; PLEASE
3880: 20 4f 50 54 49 4d 49 5a 45 20 4d 45 21 21 21 20 OPTIMIZE ME!!!
3890: 49 20 74 68 69 6e 6b 20 74 68 69 73 20 73 68 6f I think this sho
38a0: 75 6c 64 20 62 65 20 61 20 6e 6f 2d 6f 70 20 62 uld be a no-op b
38b0: 75 74 20 74 68 65 72 65 20 61 72 65 20 73 65 76 ut there are sev
38c0: 65 72 61 6c 20 70 6c 61 63 65 73 20 77 68 65 72 eral places wher
38d0: 65 20 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f e change-directo
38e0: 72 69 65 73 20 63 6f 75 6c 64 20 62 65 20 68 61 ries could be ha
38f0: 70 70 65 6e 69 6e 67 2e 0a 09 20 20 28 73 65 74 ppening... (set
3900: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d env "MT_TEST_NAM
3910: 45 22 20 68 65 64 29 20 3b 3b 20 0a 09 20 20 28 E" hed) ;; .. (
3920: 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 let* ((config (
3930: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
3940: 6e 66 69 67 20 68 65 64 20 61 6c 6c 2d 74 65 73 nfig hed all-tes
3950: 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 74 ts-registry 'ret
3960: 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 20 28 urn-procs))... (
3970: 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 69 waitons (let ((i
3980: 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 20 nstr (if config
3990: 0a 09 09 09 09 09 20 20 20 28 63 6f 6e 66 69 67 ...... (config
39a0: 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 -lookup config "
39b0: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 requirements" "w
39c0: 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 20 20 aiton")......
39d0: 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e (begin ;; No con
39e0: 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 fig means this i
39f0: 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 s a non-existant
3a00: 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 20 test......
3a10: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
3a20: 45 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 ERROR: non-exist
3a30: 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 73 ent required tes
3a40: 74 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 0a t \"" hed "\"").
3a50: 09 09 09 09 09 20 20 20 20 20 28 65 78 69 74 20 ..... (exit
3a60: 31 29 29 29 29 29 0a 09 09 09 20 20 20 20 28 64 1))))).... (d
3a70: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3a80: 38 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e 8 "waitons strin
3a90: 67 20 69 73 20 22 20 69 6e 73 74 72 29 0a 09 09 g is " instr)...
3aa0: 09 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 77 . (let ((neww
3ab0: 61 69 74 6f 6e 73 0a 09 09 09 09 20 20 20 28 73 aitons..... (s
3ac0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e tring-split (con
3ad0: 64 0a 09 09 09 09 09 09 20 20 28 28 70 72 6f 63 d....... ((proc
3ae0: 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 09 edure? instr)...
3af0: 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 72 65 .... (let ((re
3b00: 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 09 s (instr))).....
3b10: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
3b20: 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 int-info 8 "wait
3b30: 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 on procedure res
3b40: 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 ults in string "
3b50: 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 res " for test
3b60: 22 20 68 65 64 29 0a 09 09 09 09 09 09 20 20 20 " hed).......
3b70: 20 20 72 65 73 29 29 0a 09 09 09 09 09 09 20 20 res)).......
3b80: 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 ((string? instr)
3b90: 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 09 instr).....
3ba0: 09 09 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 .. (else ......
3bb0: 09 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 . ;; NOTE: Thi
3bc0: 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 s is actually th
3bd0: 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 e case of *no* w
3be0: 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 aitons! ;; (debu
3bf0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
3c00: 3a 20 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 : something went
3c10: 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 wrong in proces
3c20: 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 sing waitons for
3c30: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
3c40: 09 09 09 20 20 20 22 22 29 29 29 29 29 0a 09 09 ... "")))))...
3c50: 09 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 . (filter (
3c60: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 lambda (x)......
3c70: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
3c80: 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d ref/default all-
3c90: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 tests-registry x
3ca0: 20 23 66 29 0a 09 09 09 09 09 20 20 20 20 23 74 #f)...... #t
3cb0: 0a 09 09 09 09 09 20 20 20 20 28 62 65 67 69 6e ...... (begin
3cc0: 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 ...... (deb
3cd0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
3ce0: 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 R: test " hed "
3cf0: 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 has unrecognised
3d00: 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d 65 waiton testname
3d10: 20 22 20 78 29 0a 09 09 09 09 09 20 20 20 20 20 " x)......
3d20: 20 23 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 #f))).....
3d30: 20 6e 65 77 77 61 69 74 6f 6e 73 29 29 29 29 29 newwaitons)))))
3d40: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
3d50: 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f nt-info 8 "waito
3d60: 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a 09 ns: " waitons)..
3d70: 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 ;; check for
3d80: 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 hed in waitons
3d90: 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 => this would be
3da0: 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 circular, remov
3db0: 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 e it and issue a
3dc0: 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a n.. ;; error.
3dd0: 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 . (if (member
3de0: 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 hed waitons)...
3df0: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
3e00: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
3e10: 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 : test " hed " h
3e20: 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 as listed itself
3e30: 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c as a waiton, pl
3e40: 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 ease correct thi
3e50: 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 s!")... (set! w
3e60: 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 aitons (filter (
3e70: 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 lambda (x)(not (
3e80: 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 equal? x hed)))
3e90: 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 waitons))))..
3ea0: 20 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 .. ;; (items
3eb0: 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 (items:get-it
3ec0: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 ems-from-config
3ed0: 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 20 28 config))).. (
3ee0: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
3ef0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
3f00: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
3f10: 20 23 66 29 29 0a 09 09 28 68 61 73 68 2d 74 61 #f))...(hash-ta
3f20: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
3f30: 63 6f 72 64 73 0a 09 09 09 09 20 68 65 64 20 28 cords..... hed (
3f40: 76 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b vector hed ;
3f50: 3b 20 30 0a 09 09 09 09 09 20 20 20 20 20 63 6f ; 0...... co
3f60: 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 nfig ;; 1......
3f70: 20 20 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 waitons ;;
3f80: 32 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 2...... (con
3f90: 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 fig-lookup confi
3fa0: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
3fb0: 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 "priority")
3fc0: 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 ;; priority 3..
3fd0: 09 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 .... (let ((
3fe0: 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 items (hash
3ff0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4000: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
4010: 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 " #f)) ;; items
4020: 34 0a 09 09 09 09 09 09 20 20 20 28 69 74 65 6d 4....... (item
4030: 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 stable (hash-tab
4040: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
4050: 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c onfig "itemstabl
4060: 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 20 e" #f))) ......
4070: 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 ;; if eith
4080: 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d er items or item
4090: 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f s table is a pro
40a0: 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 c return it so t
40b0: 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 est running.....
40c0: 09 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 . ;; proce
40d0: 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 ss can know to c
40e0: 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 all items:get-it
40f0: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a ems-from-config.
4100: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 ..... ;; i
4110: 66 20 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 f either is a li
4120: 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 st and none is a
4130: 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 proc go ahead a
4140: 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d nd call get-item
4150: 73 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b s...... ;;
4160: 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 72 otherwise retur
4170: 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e n #f - this is n
4180: 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 ot an iterated t
4190: 65 73 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 est......
41a0: 28 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 72 (cond.......((pr
41b0: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 ocedure? items)
41c0: 20 20 20 20 20 0a 09 09 09 09 09 09 20 28 64 65 ....... (de
41d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
41e0: 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f "items is a pro
41f0: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
4200: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
4210: 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 items)
4220: 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 ;; calc later
4230: 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 .......((procedu
4240: 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 0a re? itemstable).
4250: 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
4260: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d int-info 4 "item
4270: 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 stable is a proc
4280: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
4290: 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 later").......
42a0: 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 itemstable)
42b0: 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a ;; calc later.
42c0: 09 09 09 09 09 09 28 28 66 69 6c 74 65 72 20 28 ......((filter (
42d0: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 lambda (x)......
42e0: 09 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 .. (let ((val
42f0: 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 (car x))).......
4300: 09 20 20 20 20 20 28 69 66 20 28 70 72 6f 63 65 . (if (proce
4310: 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 dure? val) val #
4320: 66 29 29 29 0a 09 09 09 09 09 09 09 20 28 61 70 f)))........ (ap
4330: 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 pend (if (list?
4340: 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 items) items '()
4350: 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 28 )......... (if (
4360: 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 list? itemstable
4370: 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 ) itemstable '()
4380: 29 29 29 0a 09 09 09 09 09 09 20 27 68 61 76 65 )))....... 'have
4390: 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 -procedure).....
43a0: 09 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 ..((or (list? it
43b0: 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 ems)(list? items
43c0: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 table)) ;; calc
43d0: 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 65 62 75 now....... (debu
43e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
43f0: 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 items and itemst
4400: 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c 20 able are lists,
4410: 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 calc now\n".....
4420: 09 09 09 09 20 20 20 22 20 20 20 20 69 74 65 6d .... " item
4430: 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 s: " items " ite
4440: 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 mstable: " items
4450: 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 69 table)....... (i
4460: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
4470: 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 rom-config confi
4480: 67 29 29 0a 09 09 09 09 09 09 28 65 6c 73 65 20 g)).......(else
4490: 23 66 29 29 29 20 20 20 20 20 20 20 20 20 20 20 #f)))
44a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44b0: 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a ;; not iterated.
44c0: 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 20 ..... #f
44d0: 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 0a ;; itemsdat 5.
44e0: 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 20 ..... #f
44f0: 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 ;; spare - use
4500: 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a d for item-path.
4510: 09 09 09 09 09 20 20 20 20 20 29 29 29 0a 09 20 ..... )))..
4520: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 (for-each ..
4530: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 69 (lambda (wai
4540: 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 69 66 ton).. (if
4550: 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f (and waiton (no
4560: 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e t (member waiton
4570: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 test-names)))..
4580: 09 20 20 20 28 6c 65 74 20 28 28 6e 65 77 2d 74 . (let ((new-t
4590: 65 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 est-patts (tests
45a0: 3a 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 :extend-test-pat
45b0: 74 73 20 74 65 73 74 2d 70 61 74 74 73 20 68 65 ts test-patts he
45c0: 64 20 77 61 69 74 6f 6e 20 23 66 29 29 29 0a 09 d waiton #f)))..
45d0: 09 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f . ;; need to
45e0: 20 61 63 63 6f 75 6e 74 20 66 6f 72 20 74 65 73 account for tes
45f0: 74 2d 70 61 74 74 20 68 65 72 65 2c 20 69 66 20 t-patt here, if
4600: 49 20 61 6d 20 74 65 73 74 20 22 61 22 2c 20 73 I am test "a", s
4610: 65 6c 65 63 74 65 64 20 77 69 74 68 20 61 20 74 elected with a t
4620: 65 73 74 2d 70 61 74 74 20 6f 66 20 22 68 65 64 est-patt of "hed
4630: 2f 62 25 22 0a 09 09 20 20 20 20 20 3b 3b 20 61 /b%"... ;; a
4640: 6e 64 20 77 65 20 61 72 65 20 77 61 69 74 69 6e nd we are waitin
4650: 67 20 6f 6e 20 22 77 61 69 74 6f 6e 22 20 77 65 g on "waiton" we
4660: 20 6e 65 65 64 20 74 6f 20 61 64 64 20 22 77 61 need to add "wa
4670: 69 74 6f 6e 2f 2c 77 61 69 74 6f 6e 2f 62 25 22 iton/,waiton/b%"
4680: 20 74 6f 20 74 65 73 74 2d 70 61 74 74 0a 09 09 to test-patt...
4690: 20 20 20 20 20 3b 3b 20 69 73 20 74 68 69 73 20 ;; is this
46a0: 73 61 74 69 73 66 69 65 64 20 62 79 20 6d 65 72 satisfied by mer
46b0: 65 6c 79 20 61 70 70 65 6e 64 69 6e 67 20 22 2f ely appending "/
46c0: 22 20 74 6f 20 74 68 65 20 77 61 69 74 6f 6e 20 " to the waiton
46d0: 6e 61 6d 65 20 61 64 64 65 64 20 74 6f 20 74 68 name added to th
46e0: 65 20 6c 69 73 74 3f 0a 09 09 20 20 20 20 20 3b e list?... ;
46f0: 3b 0a 09 09 20 20 20 20 20 3b 3b 20 54 68 69 73 ;... ;; This
4700: 20 61 70 70 72 6f 61 63 68 20 63 61 75 73 65 73 approach causes
4710: 20 61 6c 6c 20 6f 66 20 74 68 65 20 69 74 65 6d all of the item
4720: 73 20 69 6e 20 61 6e 20 75 70 73 74 72 65 61 6d s in an upstream
4730: 20 74 65 73 74 20 74 6f 20 62 65 20 72 75 6e 20 test to be run
4740: 0a 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
4750: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 6e 65 print-info 0 "ne
4760: 77 2d 74 65 73 74 2d 70 61 74 74 73 3a 20 22 20 w-test-patts: "
4770: 6e 65 77 2d 74 65 73 74 2d 70 61 74 74 73 20 22 new-test-patts "
4780: 2c 20 70 72 65 76 20 74 65 73 74 2d 70 61 74 74 , prev test-patt
4790: 73 3a 20 22 20 74 65 73 74 2d 70 61 74 74 73 29 s: " test-patts)
47a0: 0a 09 09 20 20 20 20 20 28 69 66 20 28 65 71 75 ... (if (equ
47b0: 61 6c 3f 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 al? new-test-pat
47c0: 74 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 09 ts test-patts)..
47d0: 09 09 20 28 73 65 74 21 20 72 65 71 75 69 72 65 .. (set! require
47e0: 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 d-tests (cons wa
47f0: 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 iton required-te
4800: 73 74 73 29 29 20 3b 3b 20 28 63 6f 6e 73 20 28 sts)) ;; (cons (
4810: 63 6f 6e 63 20 77 61 69 74 6f 6e 20 22 2f 22 29 conc waiton "/")
4820: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
4830: 29 0a 09 09 09 20 28 73 65 74 21 20 74 65 73 74 ).... (set! test
4840: 2d 70 61 74 74 73 20 6e 65 77 2d 74 65 73 74 2d -patts new-test-
4850: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 0a patts))... .
4860: 09 09 20 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 .. ;; NOPE:
4870: 64 69 64 6e 27 74 20 77 6f 72 6b 2e 20 72 65 71 didn't work. req
4880: 75 69 72 65 64 20 6e 65 65 64 73 20 74 6f 20 62 uired needs to b
4890: 65 20 70 6c 61 69 6e 20 74 65 73 74 20 6e 61 6d e plain test nam
48a0: 65 73 2e 20 54 72 79 20 74 61 63 6b 69 6e 67 20 es. Try tacking
48b0: 6f 6e 20 74 6f 20 74 65 73 74 2d 70 61 74 74 73 on to test-patts
48c0: 0a 09 09 20 20 20 20 20 3b 3b 20 20 2d 20 64 6f ... ;; - do
48d0: 65 73 6e 27 74 20 77 6f 72 6b 0a 09 09 20 20 20 esn't work...
48e0: 20 20 3b 3b 20 28 73 65 74 21 20 74 65 73 74 2d ;; (set! test-
48f0: 70 61 74 74 73 20 28 63 6f 6e 63 20 74 65 73 74 patts (conc test
4900: 2d 70 61 74 74 73 20 22 2c 22 20 77 61 69 74 6f -patts "," waito
4910: 6e 20 22 2f 22 29 29 0a 09 09 20 20 20 20 20 0a n "/"))... .
4920: 09 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 .. (set! tes
4930: 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 t-names (cons wa
4940: 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 iton test-names)
4950: 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 )))) ;; was an a
4960: 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e ppend, now a con
4970: 73 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 s.. waitons)
4980: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d .. (let ((rem
4990: 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 tests (delete-du
49a0: 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 plicates (append
49b0: 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 waitons tal))))
49c0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 .. (if (not
49d0: 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 (null? remtests
49e0: 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 ))... (loop (ca
49f0: 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 r remtests)(cdr
4a00: 72 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a remtests))))))).
4a10: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e . (if (not (n
4a20: 75 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 ull? required-te
4a30: 73 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 sts))..(debug:pr
4a40: 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 69 int-info 1 "Addi
4a50: 6e 67 20 5c 22 22 20 28 73 74 72 69 6e 67 2d 69 ng \"" (string-i
4a60: 6e 74 65 72 73 70 65 72 73 65 20 72 65 71 75 69 ntersperse requi
4a70: 72 65 64 2d 74 65 73 74 73 20 22 20 22 29 20 22 red-tests " ") "
4a80: 5c 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 \" to the run qu
4a90: 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f eue")). ;; NO
4aa0: 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c TE: these are al
4ab0: 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 l parent tests,
4ac0: 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 items are not ex
4ad0: 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 panded yet..
4ae0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4af0: 6f 20 34 20 22 74 65 73 74 2d 72 65 63 6f 72 64 o 4 "test-record
4b00: 73 3d 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d s=" (hash-table-
4b10: 3e 61 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f >alist test-reco
4b20: 72 64 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 rds)). (let (
4b30: 28 72 65 67 6c 65 6e 20 28 63 6f 6e 66 69 67 66 (reglen (configf
4b40: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
4b50: 61 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e at* "setup" "run
4b60: 71 75 65 75 65 22 29 29 29 0a 20 20 20 20 20 20 queue"))).
4b70: 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 (if (> (length (
4b80: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
4b90: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 20 30 test-records)) 0
4ba0: 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 6b 65 65 ).. (let* ((kee
4bb0: 70 2d 67 6f 69 6e 67 20 20 20 20 20 20 20 20 23 p-going #
4bc0: 74 29 0a 09 09 20 28 72 75 6e 2d 71 75 65 75 65 t)... (run-queue
4bd0: 2d 72 65 74 72 69 65 73 20 35 29 0a 09 09 20 28 -retries 5)... (
4be0: 74 68 31 20 20 20 20 20 20 20 20 28 6d 61 6b 65 th1 (make
4bf0: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
4c00: 28 29 0a 09 09 09 09 09 20 20 20 20 28 68 61 6e ()...... (han
4c10: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
4c20: 09 09 09 09 20 20 20 20 20 65 78 6e 0a 09 09 09 .... exn....
4c30: 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 .. (begin...
4c40: 09 09 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 ... (print
4c50: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
4c60: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
4c70: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 64 )...... (d
4c80: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
4c90: 52 4f 52 3a 20 66 61 69 6c 75 72 65 20 69 6e 20 ROR: failure in
4ca0: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
4cb0: 75 65 75 65 20 74 68 72 65 61 64 2c 20 65 72 72 ueue thread, err
4cc0: 6f 72 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f or: " ((conditio
4cd0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
4ce0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
4cf0: 65 29 20 65 78 6e 29 29 0a 09 09 09 09 09 20 20 e) exn))......
4d00: 20 20 20 20 20 28 69 66 20 28 3e 20 72 75 6e 2d (if (> run-
4d10: 71 75 65 75 65 2d 72 65 74 72 69 65 73 20 30 29 queue-retries 0)
4d20: 0a 09 09 09 09 09 09 20 20 20 28 62 65 67 69 6e ....... (begin
4d30: 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 65 74 ....... (set
4d40: 21 20 72 75 6e 2d 71 75 65 75 65 2d 72 65 74 72 ! run-queue-retr
4d50: 69 65 73 20 28 2d 20 72 75 6e 2d 71 75 65 75 65 ies (- run-queue
4d60: 2d 72 65 74 72 69 65 73 20 31 29 29 0a 09 09 09 -retries 1))....
4d70: 09 09 09 20 20 20 20 20 28 72 75 6e 73 3a 72 75 ... (runs:ru
4d80: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
4d90: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
4da0: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
4db0: 73 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 s flags test-pat
4dc0: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test
4dd0: 73 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 72 s (any->number r
4de0: 65 67 6c 65 6e 29 20 61 6c 6c 2d 74 65 73 74 73 eglen) all-tests
4df0: 2d 72 65 67 69 73 74 72 79 29 29 29 29 0a 09 09 -registry))))...
4e00: 09 09 09 20 20 20 20 20 28 72 75 6e 73 3a 72 75 ... (runs:ru
4e10: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
4e20: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
4e30: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
4e40: 73 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 s flags test-pat
4e50: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test
4e60: 73 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 72 s (any->number r
4e70: 65 67 6c 65 6e 29 20 61 6c 6c 2d 74 65 73 74 73 eglen) all-tests
4e80: 2d 72 65 67 69 73 74 72 79 29 29 29 0a 09 09 09 -registry)))....
4e90: 09 09 20 20 22 72 75 6e 73 3a 72 75 6e 2d 74 65 .. "runs:run-te
4ea0: 73 74 73 2d 71 75 65 75 65 22 29 29 0a 09 09 20 sts-queue"))...
4eb0: 28 74 68 32 20 20 20 20 20 20 20 20 28 6d 61 6b (th2 (mak
4ec0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
4ed0: 20 28 29 09 09 09 09 20 20 20 20 0a 09 09 09 09 ().... .....
4ee0: 09 20 20 20 20 3b 3b 20 28 72 6d 74 3a 66 69 6e . ;; (rmt:fin
4ef0: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
4f00: 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 29 29 plete-all-runs))
4f10: 29 29 29 20 43 41 4e 27 54 20 49 4e 54 45 52 52 ))) CAN'T INTERR
4f20: 55 50 54 20 49 54 20 2e 2e 2e 0a 09 09 09 09 09 UPT IT .........
4f30: 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 (let ((run-i
4f40: 64 73 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d ds (rmt:get-all-
4f50: 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 09 09 09 run-ids)))......
4f60: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
4f70: 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 (lambda (run-id)
4f80: 0a 09 09 09 09 09 09 09 20 20 28 69 66 20 6b 65 ........ (if ke
4f90: 65 70 2d 67 6f 69 6e 67 0a 09 09 09 09 09 09 09 ep-going........
4fa0: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex
4fb0: 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 09 09 ceptions........
4fc0: 20 20 20 20 20 20 20 65 78 6e 0a 09 09 09 09 09 exn......
4fd0: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
4fe0: 70 72 69 6e 74 20 30 20 22 65 72 72 6f 72 20 69 print 0 "error i
4ff0: 6e 20 63 61 6c 6c 69 6e 67 20 66 69 6e 64 2d 61 n calling find-a
5000: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
5010: 74 65 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 te for run-id "
5020: 72 75 6e 2d 69 64 29 0a 09 09 09 09 09 09 09 20 run-id)........
5030: 20 20 20 20 20 20 28 72 6d 74 3a 66 69 6e 64 2d (rmt:find-
5040: 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c and-mark-incompl
5050: 65 74 65 20 72 75 6e 2d 69 64 20 23 66 29 29 29 ete run-id #f)))
5060: 29 20 3b 3b 20 6f 76 72 2d 64 65 61 64 74 69 6d ) ;; ovr-deadtim
5070: 65 29 29 29 0a 09 09 09 09 09 09 09 72 75 6e 2d e)))........run-
5080: 69 64 73 29 29 29 0a 09 09 09 09 09 20 20 22 72 ids)))...... "r
5090: 75 6e 73 3a 20 6d 61 72 6b 2d 69 6e 63 6f 6d 70 uns: mark-incomp
50a0: 6c 65 74 65 73 22 29 29 29 0a 09 20 20 20 20 28 letes"))).. (
50b0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
50c0: 31 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 1).. (thread-
50d0: 73 74 61 72 74 21 20 74 68 32 29 0a 09 20 20 20 start! th2)..
50e0: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
50f0: 68 31 29 0a 09 20 20 20 20 28 73 65 74 21 20 6b h1).. (set! k
5100: 65 65 70 2d 67 6f 69 6e 67 20 23 66 29 0a 09 20 eep-going #f)..
5110: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
5120: 20 74 68 32 29 0a 09 20 20 20 20 3b 3b 20 69 66 th2).. ;; if
5130: 20 72 75 6e 2d 63 6f 75 6e 74 20 3e 20 30 20 63 run-count > 0 c
5140: 61 6c 6c 2c 20 73 65 74 20 2d 70 72 65 63 6c 65 all, set -precle
5150: 61 6e 20 61 6e 64 20 2d 72 65 72 75 6e 20 53 54 an and -rerun ST
5160: 55 43 4b 2f 44 45 41 44 0a 09 20 20 20 20 28 69 UCK/DEAD.. (i
5170: 66 20 28 3e 20 72 75 6e 2d 63 6f 75 6e 74 20 30 f (> run-count 0
5180: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
5190: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
51a0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
51b0: 66 6c 61 67 73 20 22 2d 70 72 65 63 6c 65 61 6e flags "-preclean
51c0: 22 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 28 " #f))... (
51d0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
51e0: 66 6c 61 67 73 20 22 2d 70 72 65 63 6c 65 61 6e flags "-preclean
51f0: 22 20 23 74 29 29 0a 09 09 20 20 28 69 66 20 28 " #t))... (if (
5200: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
5210: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
5220: 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a s "-rerun" #f)).
5230: 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
5240: 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 20 22 ble-set! flags "
5250: 2d 72 65 72 75 6e 22 20 22 53 54 55 43 4b 2f 44 -rerun" "STUCK/D
5260: 45 41 44 2c 6e 2f 61 2c 5a 45 52 4f 5f 49 54 45 EAD,n/a,ZERO_ITE
5270: 4d 53 22 29 29 0a 09 09 20 20 3b 3b 20 72 65 63 MS"))... ;; rec
5280: 75 72 73 69 76 65 20 63 61 6c 6c 20 74 6f 20 73 ursive call to s
5290: 65 6c 66 0a 09 09 20 20 28 72 75 6e 73 3a 72 75 elf... (runs:ru
52a0: 6e 2d 74 65 73 74 73 20 74 61 72 67 65 74 20 72 n-tests target r
52b0: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 unname test-patt
52c0: 73 20 75 73 65 72 20 66 6c 61 67 73 20 72 75 6e s user flags run
52d0: 2d 63 6f 75 6e 74 3a 20 28 2d 20 72 75 6e 2d 63 -count: (- run-c
52e0: 6f 75 6e 74 20 31 29 29 29 29 29 0a 09 20 20 28 ount 1))))).. (
52f0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5300: 20 30 20 22 4e 6f 20 74 65 73 74 73 20 74 6f 20 0 "No tests to
5310: 72 75 6e 22 29 29 29 0a 20 20 20 20 28 64 65 62 run"))). (deb
5320: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
5330: 22 41 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 "All done by her
5340: 65 22 29 0a 20 20 20 20 28 72 6d 74 3a 74 61 73 e"). (rmt:tas
5350: 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 ks-set-state-giv
5360: 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 74 61 73 en-param-key tas
5370: 6b 2d 6b 65 79 20 22 64 6f 6e 65 22 29 0a 20 20 k-key "done").
5380: 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 ;; (sqlite3:fi
5390: 6e 61 6c 69 7a 65 21 20 74 61 73 6b 73 2d 64 62 nalize! tasks-db
53a0: 29 0a 20 20 20 20 29 29 0a 0a 0a 3b 3b 20 6c 6f ). ))...;; lo
53b0: 6f 70 20 6c 6f 67 69 63 2e 20 54 68 65 73 65 20 op logic. These
53c0: 61 72 65 20 75 73 65 64 20 69 6e 20 72 75 6e 73 are used in runs
53d0: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
53e0: 20 74 6f 20 6d 61 6b 65 20 69 74 20 61 20 62 69 to make it a bi
53f0: 74 20 6d 6f 72 65 20 72 65 61 64 61 62 6c 65 2e t more readable.
5400: 0a 3b 3b 0a 3b 3b 20 49 66 20 72 65 67 20 6e 6f .;;.;; If reg no
5410: 74 20 66 75 6c 6c 20 61 6e 64 20 68 61 76 65 20 t full and have
5420: 69 74 65 6d 73 20 69 6e 20 74 61 6c 20 74 68 65 items in tal the
5430: 6e 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 72 n loop with (car
5440: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 tal)(cdr tal) r
5450: 65 67 20 72 65 72 75 6e 73 0a 3b 3b 20 49 66 20 eg reruns.;; If
5460: 72 65 67 20 69 73 20 66 75 6c 6c 20 28 69 2e 65 reg is full (i.e
5470: 2e 20 6c 65 6e 67 74 68 20 3e 3d 20 6e 0a 3b 3b . length >= n.;;
5480: 20 20 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 loop with (ca
5490: 72 20 72 65 67 29 20 74 61 6c 20 28 63 64 72 20 r reg) tal (cdr
54a0: 72 65 67 29 20 72 65 72 75 6e 73 0a 3b 3b 20 49 reg) reruns.;; I
54b0: 66 20 74 61 6c 20 69 73 20 65 6d 70 74 79 0a 3b f tal is empty.;
54c0: 3b 20 20 20 62 75 74 20 68 61 76 65 20 69 74 65 ; but have ite
54d0: 6d 73 20 69 6e 20 72 65 67 3b 20 6c 6f 6f 70 20 ms in reg; loop
54e0: 77 69 74 68 20 28 63 61 72 20 72 65 67 29 28 63 with (car reg)(c
54f0: 64 72 20 72 65 67 29 20 27 28 29 20 72 65 72 75 dr reg) '() reru
5500: 6e 73 0a 3b 3b 20 20 20 49 66 20 72 65 67 20 69 ns.;; If reg i
5510: 73 20 65 6d 70 74 79 20 3d 3e 20 61 6c 6c 20 64 s empty => all d
5520: 6f 6e 65 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 one..(define (ru
5530: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
5540: 64 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 d tal reg n regf
5550: 75 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 ull). (if regfu
5560: 6c 6c 0a 20 20 20 20 20 20 28 63 61 72 20 72 65 ll. (car re
5570: 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 g). (if (nu
5580: 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 74 61 6c 20 ll? tal) ;; tal
5590: 69 73 20 75 73 65 64 20 75 70 2c 20 70 6f 70 20 is used up, pop
55a0: 66 72 6f 6d 20 72 65 67 0a 09 20 20 28 63 61 72 from reg.. (car
55b0: 20 72 65 67 29 0a 09 20 20 28 63 61 72 20 74 61 reg).. (car ta
55c0: 6c 29 29 29 29 0a 0a 3b 3b 20 20 20 28 63 6f 6e l))))..;; (con
55d0: 64 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 72 65 d.;; ((and re
55e0: 67 66 75 6c 6c 20 28 6e 75 6c 6c 3f 20 72 65 67 gfull (null? reg
55f0: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
5600: 29 29 29 20 20 20 20 20 20 28 63 61 72 20 74 61 ))) (car ta
5610: 6c 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 l)).;; ((and
5620: 72 65 67 66 75 6c 6c 20 28 6e 6f 74 20 28 6e 75 regfull (not (nu
5630: 6c 6c 3f 20 72 65 67 29 29 29 20 20 20 20 20 20 ll? reg)))
5640: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 (car
5650: 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e reg)).;; ((an
5660: 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c 29 28 d (not regfull)(
5670: 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 6f 74 20 28 null? tal)(not (
5680: 6e 75 6c 6c 3f 20 72 65 67 29 29 29 20 28 63 61 null? reg))) (ca
5690: 72 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 r reg)).;; ((
56a0: 61 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c and (not regfull
56b0: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
56c0: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 28 ))) (
56d0: 63 61 72 20 74 61 6c 29 29 0a 3b 3b 20 20 20 20 car tal)).;;
56e0: 28 65 6c 73 65 0a 3b 3b 20 20 20 20 20 28 64 65 (else.;; (de
56f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
5700: 4f 52 3a 20 72 75 6e 73 3a 71 75 65 75 65 2d 6e OR: runs:queue-n
5710: 65 78 74 2d 68 65 64 2c 20 74 61 6c 3d 22 20 74 ext-hed, tal=" t
5720: 61 6c 20 22 2c 20 72 65 67 3d 22 20 72 65 67 20 al ", reg=" reg
5730: 22 2c 20 6e 3d 22 20 6e 20 22 2c 20 72 65 67 66 ", n=" n ", regf
5740: 75 6c 6c 3d 22 20 72 65 67 66 75 6c 6c 29 0a 3b ull=" regfull).;
5750: 3b 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 ; #f)))..(de
5760: 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 fine (runs:queue
5770: 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 -next-tal tal re
5780: 67 20 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 28 g n regfull). (
5790: 69 66 20 72 65 67 66 75 6c 6c 0a 20 20 20 20 20 if regfull.
57a0: 20 74 61 6c 0a 20 20 20 20 20 20 28 69 66 20 28 tal. (if (
57b0: 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 6d 75 null? tal) ;; mu
57c0: 73 74 20 74 72 61 6e 73 66 65 72 20 66 72 6f 6d st transfer from
57d0: 20 72 65 67 0a 09 20 20 28 63 64 72 20 72 65 67 reg.. (cdr reg
57e0: 29 0a 09 20 20 28 63 64 72 20 74 61 6c 29 29 29 ).. (cdr tal)))
57f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
5800: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
5810: 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c tal reg n regful
5820: 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c 6c l). (if regfull
5830: 0a 20 20 20 20 20 20 28 63 64 72 20 72 65 67 29 . (cdr reg)
5840: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
5850: 3f 20 74 61 6c 29 20 3b 3b 20 69 66 20 74 61 6c ? tal) ;; if tal
5860: 20 69 73 20 6e 75 6c 6c 20 61 6e 64 20 72 65 67 is null and reg
5870: 20 6e 6f 74 20 66 75 6c 6c 20 74 68 65 6e 20 27 not full then '
5880: 28 29 20 61 73 20 72 65 67 20 63 6f 6e 74 65 6e () as reg conten
5890: 74 73 20 6d 6f 76 65 64 20 74 6f 20 74 61 6c 0a ts moved to tal.
58a0: 09 20 20 27 28 29 0a 09 20 20 72 65 67 29 29 29 . '().. reg)))
58b0: 0a 0a 28 64 65 66 69 6e 65 20 72 75 6e 73 3a 6e ..(define runs:n
58c0: 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 othing-left-in-q
58d0: 75 65 75 65 2d 63 6f 75 6e 74 20 30 29 0a 0a 28 ueue-count 0)..(
58e0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 65 78 70 define (runs:exp
58f0: 61 6e 64 2d 69 74 65 6d 73 20 68 65 64 20 74 61 and-items hed ta
5900: 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 67 l reg reruns reg
5910: 66 75 6c 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 67 full newtal jobg
5920: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
5930: 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 ent-jobs run-id
5940: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
5950: 68 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d h testmode test-
5960: 72 65 63 6f 72 64 20 63 61 6e 2d 72 75 6e 2d 6d record can-run-m
5970: 6f 72 65 20 69 74 65 6d 73 20 72 75 6e 6e 61 6d ore items runnam
5980: 65 20 74 63 6f 6e 66 69 67 20 72 65 67 6c 65 6e e tconfig reglen
5990: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 test-registry t
59a0: 65 73 74 2d 72 65 63 6f 72 64 73 20 69 74 65 6d est-records item
59b0: 6d 61 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c map). (let* ((l
59c0: 6f 6f 70 2d 6c 69 73 74 20 20 20 20 20 20 20 28 oop-list (
59d0: 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 list hed tal reg
59e0: 20 72 65 72 75 6e 73 29 29 0a 09 20 28 70 72 65 reruns)).. (pre
59f0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 72 6d reqs-not-met (rm
5a00: 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f t:get-prereqs-no
5a10: 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 t-met run-id wai
5a20: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d tons item-path m
5a30: 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 20 69 74 ode: testmode it
5a40: 65 6d 6d 61 70 3a 20 69 74 65 6d 6d 61 70 29 29 emmap: itemmap))
5a50: 0a 09 20 3b 3b 20 28 70 72 65 72 65 71 73 2d 6e .. ;; (prereqs-n
5a60: 6f 74 2d 6d 65 74 20 28 6d 74 3a 6c 61 7a 79 2d ot-met (mt:lazy-
5a70: 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d get-prereqs-not-
5a80: 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f met run-id waito
5a90: 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 ns item-path mod
5aa0: 65 3a 20 74 65 73 74 6d 6f 64 65 20 69 74 65 6d e: testmode item
5ab0: 6d 61 70 3a 20 69 74 65 6d 6d 61 70 29 29 0a 09 map: itemmap))..
5ac0: 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 (fails
5ad0: 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 (runs:calc-fai
5ae0: 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ls prereqs-not-m
5af0: 65 74 29 29 0a 09 20 28 70 72 65 72 65 71 2d 66 et)).. (prereq-f
5b00: 61 69 6c 73 20 20 20 20 28 72 75 6e 73 3a 63 61 ails (runs:ca
5b10: 6c 63 2d 70 72 65 72 65 71 2d 66 61 69 6c 20 70 lc-prereq-fail p
5b20: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
5b30: 0a 09 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 .. (non-complete
5b40: 64 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e d (runs:calc-n
5b50: 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 ot-completed pre
5b60: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 reqs-not-met))..
5b70: 20 28 72 75 6e 6e 61 62 6c 65 73 20 20 20 20 20 (runnables
5b80: 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 72 75 6e (runs:calc-run
5b90: 6e 61 62 6c 65 20 70 72 65 72 65 71 73 2d 6e 6f nable prereqs-no
5ba0: 74 2d 6d 65 74 29 29 29 0a 20 20 20 20 28 64 65 t-met))). (de
5bb0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
5bc0: 20 22 53 54 41 52 54 20 4f 46 20 49 4e 4e 45 52 "START OF INNER
5bd0: 20 43 4f 4e 44 20 23 32 20 22 0a 09 09 20 20 20 COND #2 "...
5be0: 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d "\n can-run-m
5bf0: 6f 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 75 ore: " can-ru
5c00: 6e 2d 6d 6f 72 65 0a 09 09 20 20 20 20 20 20 22 n-more... "
5c10: 5c 6e 20 74 65 73 74 6e 61 6d 65 3a 20 20 20 20 \n testname:
5c20: 20 20 20 20 22 20 68 65 64 0a 09 09 20 20 20 20 " hed...
5c30: 20 20 22 5c 6e 20 70 72 65 72 65 71 73 2d 6e 6f "\n prereqs-no
5c40: 74 2d 6d 65 74 3a 20 22 20 28 72 75 6e 73 3a 70 t-met: " (runs:p
5c50: 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 72 65 retty-string pre
5c60: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 reqs-not-met)...
5c70: 20 20 20 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f "\n non-co
5c80: 6d 70 6c 65 74 65 64 3a 20 20 20 22 20 28 72 75 mpleted: " (ru
5c90: 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 ns:pretty-string
5ca0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 20 non-completed)
5cb0: 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 70 72 65 ... "\n pre
5cc0: 72 65 71 2d 66 61 69 6c 73 3a 20 20 20 20 22 20 req-fails: "
5cd0: 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 (runs:pretty-str
5ce0: 69 6e 67 20 70 72 65 72 65 71 2d 66 61 69 6c 73 ing prereq-fails
5cf0: 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 66 61 )... "\n fa
5d00: 69 6c 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 ils: "
5d10: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
5d20: 72 69 6e 67 20 66 61 69 6c 73 29 0a 09 09 20 20 ring fails)...
5d30: 20 20 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 "\n testmode
5d40: 3a 20 20 20 20 20 20 20 20 22 20 74 65 73 74 6d : " testm
5d50: 6f 64 65 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 ode... "\n
5d60: 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 (member 'topleve
5d70: 6c 20 74 65 73 74 6d 6f 64 65 29 3a 20 22 20 28 l testmode): " (
5d80: 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c member 'toplevel
5d90: 20 74 65 73 74 6d 6f 64 65 29 0a 09 09 20 20 20 testmode)...
5da0: 20 20 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 6e 6f "\n (null? no
5db0: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 3a 20 20 20 n-completed):
5dc0: 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f " (null? non-co
5dd0: 6d 70 6c 65 74 65 64 29 0a 09 09 20 20 20 20 20 mpleted)...
5de0: 20 22 5c 6e 20 72 65 72 75 6e 73 3a 20 20 20 20 "\n reruns:
5df0: 20 20 20 20 20 20 22 20 72 65 72 75 6e 73 0a 09 " reruns..
5e00: 09 20 20 20 20 20 20 22 5c 6e 20 69 74 65 6d 73 . "\n items
5e10: 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 69 74 : " it
5e20: 65 6d 73 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 ems... "\n
5e30: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 20 can-run-more:
5e40: 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 " can-run-more)
5e50: 0a 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 .. (cond.
5e60: 20 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 ;; all prereqs
5e70: 6d 65 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 met, fire off th
5e80: 65 20 74 65 73 74 0a 20 20 20 20 20 3b 3b 20 6f e test. ;; o
5e90: 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 27 74 r, if it is a 't
5ea0: 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 6e 64 oplevel test and
5eb0: 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 all prereqs not
5ec0: 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 met are COMPLET
5ed0: 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a 0a ED then launch..
5ee0: 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 ((and (not
5ef0: 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 (member 'topleve
5f00: 6c 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 20 20 l testmode))..
5f10: 20 28 6d 65 6d 62 65 72 20 28 68 61 73 68 2d 74 (member (hash-t
5f20: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5f30: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
5f40: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
5f50: 6c 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 6d 2d l-name hed item-
5f60: 70 61 74 68 29 20 27 6e 2f 61 29 0a 09 09 20 20 path) 'n/a)...
5f70: 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f '(DONOTRUN remo
5f80: 76 65 64 20 43 41 4e 4e 4f 54 52 55 4e 29 29 29 ved CANNOTRUN)))
5f90: 20 3b 3b 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 ;; *common:cant
5fa0: 2d 72 75 6e 2d 73 74 61 74 65 73 2d 73 79 6d 2a -run-states-sym*
5fb0: 29 20 3b 3b 20 27 28 43 4f 4d 50 4c 45 54 45 44 ) ;; '(COMPLETED
5fc0: 20 4b 49 4c 4c 45 44 20 57 41 49 56 45 44 20 55 KILLED WAIVED U
5fd0: 4e 4b 4e 4f 57 4e 20 49 4e 43 4f 4d 50 4c 45 54 NKNOWN INCOMPLET
5fe0: 45 29 29 20 3b 3b 20 74 72 79 20 74 6f 20 63 61 E)) ;; try to ca
5ff0: 74 63 68 20 72 65 70 65 61 74 20 70 72 6f 63 65 tch repeat proce
6000: 73 73 69 6e 67 20 6f 66 20 43 4f 4d 50 4c 45 54 ssing of COMPLET
6010: 45 44 20 74 65 73 74 73 20 68 65 72 65 0a 20 20 ED tests here.
6020: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6030: 2d 69 6e 66 6f 20 31 20 22 54 65 73 74 20 22 20 -info 1 "Test "
6040: 68 65 64 20 22 20 73 65 74 20 74 6f 20 5c 22 22 hed " set to \""
6050: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6060: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
6070: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
6080: 6c 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 6d 2d l-name hed item-
6090: 70 61 74 68 29 29 20 22 5c 22 2e 20 52 65 6d 6f path)) "\". Remo
60a0: 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 68 65 ving it from the
60b0: 20 71 75 65 75 65 22 29 0a 20 20 20 20 20 20 28 queue"). (
60c0: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
60d0: 6c 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 l? tal))..
60e0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
60f0: 29 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e )).. (list (run
6100: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 s:queue-next-hed
6110: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
6120: 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 regfull)...(runs
6130: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
6140: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
6150: 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a egfull)...(runs:
6160: 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 queue-next-reg t
6170: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
6180: 67 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 gfull)...reruns)
6190: 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
61a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
61b0: 6f 20 30 20 22 4e 6f 74 68 69 6e 67 20 6c 65 66 o 0 "Nothing lef
61c0: 74 20 69 6e 20 74 68 65 20 71 75 65 75 65 21 22 t in the queue!"
61d0: 29 0a 09 20 20 20 20 3b 3b 20 49 66 20 67 65 74 ).. ;; If get
61e0: 20 68 65 72 65 20 74 77 69 63 65 20 74 68 65 6e here twice then
61f0: 20 77 65 20 6b 6e 6f 77 20 77 65 27 76 65 20 74 we know we've t
6200: 72 69 65 64 20 74 6f 20 65 78 70 61 6e 64 20 61 ried to expand a
6210: 6c 6c 20 69 74 65 6d 73 0a 09 20 20 20 20 3b 3b ll items.. ;;
6220: 20 73 69 6e 63 65 20 74 68 65 72 65 20 6d 75 73 since there mus
6230: 74 20 62 65 20 61 20 6c 6f 67 69 63 20 69 73 73 t be a logic iss
6240: 75 65 20 77 69 74 68 20 74 68 65 20 68 61 6e 64 ue with the hand
6250: 6c 69 6e 67 20 6f 66 20 6c 6f 6f 70 73 20 69 6e ling of loops in
6260: 20 74 68 65 20 0a 09 20 20 20 20 3b 3b 20 69 74 the .. ;; it
6270: 65 6d 73 20 65 78 70 61 6e 64 20 70 68 61 73 65 ems expand phase
6280: 20 77 65 20 77 69 6c 6c 20 62 72 75 74 65 20 66 we will brute f
6290: 6f 72 63 65 20 61 6e 20 65 78 69 74 20 68 65 72 orce an exit her
62a0: 65 2e 0a 09 20 20 20 20 28 69 66 20 28 3e 20 72 e... (if (> r
62b0: 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 uns:nothing-left
62c0: 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 -in-queue-count
62d0: 32 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 2)...(begin...
62e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
62f0: 57 41 52 4e 49 4e 47 3a 20 74 68 69 73 20 63 6f WARNING: this co
6300: 6e 64 69 74 69 6f 6e 20 69 73 20 74 72 69 67 67 ndition is trigg
6310: 65 72 65 64 20 77 68 65 6e 20 74 68 65 72 65 20 ered when there
6320: 77 65 72 65 20 6e 6f 20 69 74 65 6d 73 20 74 6f were no items to
6330: 20 65 78 70 61 6e 64 20 61 6e 64 20 6e 6f 74 68 expand and noth
6340: 69 6e 67 20 74 6f 20 72 75 6e 2e 20 50 6c 65 61 ing to run. Plea
6350: 73 65 20 63 68 65 63 6b 20 79 6f 75 72 20 72 75 se check your ru
6360: 6e 20 66 6f 72 20 63 6f 6d 70 6c 65 74 65 6e 65 n for completene
6370: 73 73 22 29 0a 09 09 20 20 28 65 78 69 74 20 30 ss")... (exit 0
6380: 29 29 0a 09 09 28 73 65 74 21 20 72 75 6e 73 3a ))...(set! runs:
6390: 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d nothing-left-in-
63a0: 71 75 65 75 65 2d 63 6f 75 6e 74 20 28 2b 20 72 queue-count (+ r
63b0: 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 uns:nothing-left
63c0: 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 -in-queue-count
63d0: 31 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 0a 1))).. #f))).
63e0: 0a 20 20 20 20 20 3b 3b 20 0a 20 20 20 20 20 28 . ;; . (
63f0: 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 (or (null? prere
6400: 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 20 20 28 qs-not-met).. (
6410: 61 6e 64 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 and (member 'top
6420: 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 0a level testmode).
6430: 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 6e . (null? n
6440: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a on-completed))).
6450: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6460: 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
6470: 65 78 70 61 6e 64 2d 69 74 65 6d 73 3a 20 28 6f expand-items: (o
6480: 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 r (null? prereqs
6490: 2d 6e 6f 74 2d 6d 65 74 29 20 28 61 6e 64 20 28 -not-met) (and (
64a0: 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c member 'toplevel
64b0: 20 74 65 73 74 6d 6f 64 65 29 28 6e 75 6c 6c 3f testmode)(null?
64c0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 non-completed))
64d0: 29 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 )"). (let (
64e0: 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 74 (test-name (test
64f0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
6500: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
6510: 63 6f 72 64 29 29 29 0a 09 28 73 65 74 65 6e 76 cord)))..(setenv
6520: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
6530: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 test-name) ;; ..
6540: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
6550: 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a AME" runname).
6560: 09 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 .(runs:set-megat
6570: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e est-env-vars run
6580: 2d 69 64 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 -id inrunname: r
6590: 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 unname) ;; these
65a0: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
65b0: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
65c0: 70 72 6f 63 65 73 73 0a 09 28 6c 65 74 20 28 28 process..(let ((
65d0: 69 74 65 6d 73 2d 6c 69 73 74 20 28 69 74 65 6d items-list (item
65e0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
65f0: 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 -config tconfig)
6600: 29 29 0a 09 20 20 28 69 66 20 28 6c 69 73 74 3f )).. (if (list?
6610: 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 20 20 items-list)..
6620: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 69 66 (begin...(if
6630: 20 28 6e 75 6c 6c 3f 20 69 74 65 6d 73 2d 6c 69 (null? items-li
6640: 73 74 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 st)... (let (
6650: 28 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 (test-id (rmt:ge
6660: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
6670: 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 29 29 test-name "")))
6680: 0a 09 09 20 20 20 20 20 20 28 69 66 20 74 65 73 ... (if tes
6690: 74 2d 69 64 20 28 6d 74 3a 74 65 73 74 2d 73 65 t-id (mt:test-se
66a0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
66b0: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
66c0: 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 -id "NOT_STARTED
66d0: 22 20 22 5a 45 52 4f 5f 49 54 45 4d 53 22 20 22 " "ZERO_ITEMS" "
66e0: 46 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 64 75 Failed to run du
66f0: 65 20 74 6f 20 66 61 69 6c 65 64 20 70 72 65 72 e to failed prer
6700: 65 71 75 69 73 69 74 65 73 22 29 29 29 29 0a 09 equisites"))))..
6710: 09 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 .(tests:testqueu
6720: 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 74 65 73 e-set-items! tes
6730: 74 2d 72 65 63 6f 72 64 20 69 74 65 6d 73 2d 6c t-record items-l
6740: 69 73 74 29 0a 09 09 28 6c 69 73 74 20 68 65 64 ist)...(list hed
6750: 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 29 tal reg reruns)
6760: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
6770: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
6780: 20 22 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f "ERROR: The pro
6790: 63 20 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 c from reading t
67a0: 68 65 20 69 74 65 6d 73 20 74 61 62 6c 65 20 64 he items table d
67b0: 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 6c id not yield a l
67c0: 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 ist - please rep
67d0: 6f 72 74 20 74 68 69 73 22 29 0a 09 09 28 65 78 ort this")...(ex
67e0: 69 74 20 31 29 29 29 29 29 29 0a 0a 20 20 20 20 it 1))))))..
67f0: 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 66 61 ((and (null? fa
6800: 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c 3f 20 ils).. (null?
6810: 70 72 65 72 65 71 2d 66 61 69 6c 73 29 0a 09 20 prereq-fails)..
6820: 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 6f (not (null? no
6830: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a 20 n-completed))).
6840: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 6c 6c (let* ((all
6850: 69 6e 71 75 65 75 65 20 28 6d 61 70 20 28 6c 61 inqueue (map (la
6860: 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 74 72 mbda (x)(if (str
6870: 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a 74 65 ing? x) x (db:te
6880: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
6890: 78 29 29 29 0a 20 20 20 20 20 20 20 20 09 09 20 x))). ..
68a0: 20 20 20 20 20 28 61 70 70 65 6e 64 20 6e 65 77 (append new
68b0: 74 61 6c 20 72 65 72 75 6e 73 29 29 29 0a 09 20 tal reruns)))..
68c0: 20 20 20 20 3b 3b 20 70 72 65 72 65 71 73 74 72 ;; prereqstr
68d0: 73 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 s is a list of t
68e0: 65 73 74 20 6e 61 6d 65 73 20 61 73 20 73 74 72 est names as str
68f0: 69 6e 67 73 20 74 68 61 74 20 61 72 65 20 70 72 ings that are pr
6900: 65 72 65 71 73 20 66 6f 72 20 68 65 64 0a 20 20 ereqs for hed.
6910: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 65 72 (prer
6920: 65 71 73 74 72 73 20 28 64 65 6c 65 74 65 2d 64 eqstrs (delete-d
6930: 75 70 6c 69 63 61 74 65 73 20 28 6d 61 70 20 28 uplicates (map (
6940: 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 lambda (x)(if (s
6950: 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a tring? x) x (db:
6960: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
6970: 65 20 78 29 29 29 0a 09 09 09 09 09 09 20 70 72 e x)))....... pr
6980: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 ereqs-not-met)))
6990: 0a 09 20 20 20 20 20 3b 3b 20 61 20 70 72 65 72 .. ;; a prer
69a0: 65 71 20 74 68 61 74 20 69 73 20 6e 6f 74 20 66 eq that is not f
69b0: 6f 75 6e 64 20 69 6e 20 61 6c 6c 69 6e 71 75 65 ound in allinque
69c0: 75 65 20 77 69 6c 6c 20 62 65 20 70 75 74 20 69 ue will be put i
69d0: 6e 20 74 68 65 20 6e 6f 74 69 6e 71 75 65 75 65 n the notinqueue
69e0: 20 6c 69 73 74 0a 09 20 20 20 20 20 3b 3b 20 0a list.. ;; .
69f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
6a00: 28 6e 6f 74 69 6e 71 75 65 75 65 20 28 66 69 6c (notinqueue (fil
6a10: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
6a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
6a30: 20 20 20 09 09 20 20 20 28 6e 6f 74 20 28 6d 65 .. (not (me
6a40: 6d 62 65 72 20 78 20 61 6c 6c 69 6e 71 75 65 75 mber x allinqueu
6a50: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
6a60: 20 20 3b 3b 20 20 20 20 09 09 20 70 72 65 72 65 ;; .. prere
6a70: 71 73 74 72 73 29 29 0a 09 20 20 20 20 20 28 67 qstrs)).. (g
6a80: 69 76 65 2d 75 70 20 20 20 20 23 66 29 29 0a 0a ive-up #f))..
6a90: 09 3b 3b 20 57 65 20 63 61 6e 20 67 65 74 20 68 .;; We can get h
6aa0: 65 72 65 20 77 68 65 6e 20 61 20 70 72 65 72 65 ere when a prere
6ab0: 71 20 68 61 73 20 6e 6f 74 20 62 65 65 6e 20 72 q has not been r
6ac0: 75 6e 20 64 75 65 20 74 6f 20 2a 69 74 2a 20 68 un due to *it* h
6ad0: 61 76 69 6e 67 20 61 20 70 72 65 72 65 71 20 74 aving a prereq t
6ae0: 68 61 74 20 66 61 69 6c 65 64 2e 0a 09 3b 3b 20 hat failed...;;
6af0: 57 65 20 6e 65 65 64 20 74 6f 20 75 73 65 20 74 We need to use t
6b00: 68 69 73 20 74 6f 20 64 65 71 75 65 75 65 20 74 his to dequeue t
6b10: 68 69 73 20 69 74 65 6d 20 61 73 20 43 41 4e 4e his item as CANN
6b20: 4f 54 52 55 4e 0a 09 3b 3b 20 0a 09 28 69 66 20 OTRUN..;; ..(if
6b30: 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 (member 'topleve
6b40: 6c 20 74 65 73 74 6d 6f 64 65 29 20 3b 3b 20 27 l testmode) ;; '
6b50: 28 74 6f 70 6c 65 76 65 6c 29 29 20 3b 3b 20 4e (toplevel)) ;; N
6b60: 4f 54 45 3a 20 74 68 69 73 20 70 72 6f 62 61 62 OTE: this probab
6b70: 6c 79 20 73 68 6f 75 6c 64 20 62 65 20 28 6d 65 ly should be (me
6b80: 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 mber 'toplevel t
6b90: 65 73 74 6d 6f 64 65 29 0a 09 20 20 20 20 28 66 estmode).. (f
6ba0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
6bb0: 28 70 72 65 72 65 71 29 0a 09 09 09 28 69 66 20 (prereq)....(if
6bc0: 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 (eq? (hash-table
6bd0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
6be0: 74 2d 72 65 67 69 73 74 72 79 20 70 72 65 72 65 t-registry prere
6bf0: 71 20 27 6a 75 73 74 66 69 6e 65 29 20 27 43 41 q 'justfine) 'CA
6c00: 4e 4e 4f 54 52 55 4e 29 0a 09 09 09 20 20 20 20 NNOTRUN)....
6c10: 28 73 65 74 21 20 67 69 76 65 2d 75 70 20 23 74 (set! give-up #t
6c20: 29 29 29 0a 09 09 20 20 20 20 20 20 70 72 65 72 )))... prer
6c30: 65 71 73 74 72 73 29 29 0a 0a 09 28 69 66 20 28 eqstrs))...(if (
6c40: 61 6e 64 20 67 69 76 65 2d 75 70 0a 09 09 20 28 and give-up... (
6c50: 6e 6f 74 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 not (and (null?
6c60: 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 29 29 tal)(null? reg))
6c70: 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 )).. (let ((t
6c80: 72 69 6d 6d 65 64 2d 74 61 6c 20 28 6d 74 3a 64 rimmed-tal (mt:d
6c90: 69 73 63 61 72 64 2d 62 6c 6f 63 6b 65 64 2d 74 iscard-blocked-t
6ca0: 65 73 74 73 20 72 75 6e 2d 69 64 20 68 65 64 20 ests run-id hed
6cb0: 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 73 tal test-records
6cc0: 29 29 0a 09 09 20 20 28 74 72 69 6d 6d 65 64 2d ))... (trimmed-
6cd0: 72 65 67 20 28 6d 74 3a 64 69 73 63 61 72 64 2d reg (mt:discard-
6ce0: 62 6c 6f 63 6b 65 64 2d 74 65 73 74 73 20 72 75 blocked-tests ru
6cf0: 6e 2d 69 64 20 68 65 64 20 72 65 67 20 74 65 73 n-id hed reg tes
6d00: 74 2d 72 65 63 6f 72 64 73 29 29 29 0a 09 20 20 t-records)))..
6d10: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6d20: 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 1 "WARNING: tes
6d30: 74 20 22 20 68 65 64 20 22 20 68 61 73 20 64 69 t " hed " has di
6d40: 73 63 61 72 64 65 64 20 70 72 65 72 65 71 75 69 scarded prerequi
6d50: 73 69 74 65 73 2c 20 72 65 6d 6f 76 69 6e 67 20 sites, removing
6d60: 69 74 20 66 72 6f 6d 20 74 68 65 20 71 75 65 75 it from the queu
6d70: 65 22 29 0a 0a 09 20 20 20 20 20 20 28 6c 65 74 e")... (let
6d80: 20 28 28 74 65 73 74 2d 69 64 20 28 72 6d 74 3a ((test-id (rmt:
6d90: 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
6da0: 69 64 20 68 65 64 20 22 22 29 29 29 0a 09 09 28 id hed "")))...(
6db0: 69 66 20 74 65 73 74 2d 69 64 20 28 6d 74 3a 74 if test-id (mt:t
6dc0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
6dd0: 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 atus-by-id run-i
6de0: 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 d test-id "NOT_S
6df0: 54 41 52 54 45 44 22 20 22 50 52 45 51 5f 44 49 TARTED" "PREQ_DI
6e00: 53 43 41 52 44 45 44 22 20 22 46 61 69 6c 65 64 SCARDED" "Failed
6e10: 20 74 6f 20 72 75 6e 20 64 75 65 20 74 6f 20 64 to run due to d
6e20: 69 73 63 61 72 64 65 64 20 70 72 65 72 65 71 75 iscarded prerequ
6e30: 69 73 69 74 65 73 22 29 29 29 0a 09 20 20 20 20 isites")))..
6e40: 20 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 .. (if (a
6e50: 6e 64 20 28 6e 75 6c 6c 3f 20 74 72 69 6d 6d 65 nd (null? trimme
6e60: 64 2d 74 61 6c 29 0a 09 09 20 20 20 20 20 20 20 d-tal)...
6e70: 28 6e 75 6c 6c 3f 20 74 72 69 6d 6d 65 64 2d 72 (null? trimmed-r
6e80: 65 67 29 29 0a 09 09 20 20 23 66 0a 09 09 20 20 eg))... #f...
6e90: 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 (list (runs:queu
6ea0: 65 2d 6e 65 78 74 2d 68 65 64 20 74 72 69 6d 6d e-next-hed trimm
6eb0: 65 64 2d 74 61 6c 20 74 72 69 6d 6d 65 64 2d 72 ed-tal trimmed-r
6ec0: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6ed0: 6c 29 0a 09 09 09 28 72 75 6e 73 3a 71 75 65 75 l)....(runs:queu
6ee0: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 72 69 6d 6d e-next-tal trimm
6ef0: 65 64 2d 74 61 6c 20 74 72 69 6d 6d 65 64 2d 72 ed-tal trimmed-r
6f00: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6f10: 6c 29 0a 09 09 09 28 72 75 6e 73 3a 71 75 65 75 l)....(runs:queu
6f20: 65 2d 6e 65 78 74 2d 72 65 67 20 74 72 69 6d 6d e-next-reg trimm
6f30: 65 64 2d 74 61 6c 20 74 72 69 6d 6d 65 64 2d 72 ed-tal trimmed-r
6f40: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6f50: 6c 29 0a 09 09 09 72 65 72 75 6e 73 29 29 29 0a l)....reruns))).
6f60: 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 . (list (ca
6f70: 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e 64 r newtal)(append
6f80: 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 (cdr newtal) re
6f90: 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 29 29 g) '() reruns)))
6fa0: 29 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e ).. ((and (n
6fb0: 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 20 20 20 ull? fails)..
6fc0: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 2d 66 61 (null? prereq-fa
6fd0: 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c 3f 20 ils).. (null?
6fe0: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 0a non-completed)).
6ff0: 20 20 20 20 20 20 28 69 66 20 20 28 72 75 6e 73 (if (runs
7000: 3a 63 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e :can-keep-runnin
7010: 67 3f 20 68 65 64 20 32 30 29 0a 09 20 20 28 62 g? hed 20).. (b
7020: 65 67 69 6e 0a 09 20 20 20 20 28 72 75 6e 73 3a egin.. (runs:
7030: 69 6e 63 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 inc-cant-run-tes
7040: 74 73 20 68 65 64 29 0a 09 20 20 20 20 28 64 65 ts hed).. (de
7050: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
7060: 20 22 6e 6f 20 66 61 69 6c 73 20 69 6e 20 70 72 "no fails in pr
7070: 65 72 65 71 75 69 73 69 74 65 73 20 66 6f 72 20 erequisites for
7080: 22 20 68 65 64 20 22 20 62 75 74 20 61 6c 73 6f " hed " but also
7090: 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 2c 20 6b none running, k
70a0: 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 20 66 eeping " hed " f
70b0: 6f 72 20 6e 6f 77 2e 20 54 72 79 20 63 6f 75 6e or now. Try coun
70c0: 74 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 t: " (hash-table
70d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 -ref/default *se
70e0: 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 en-cant-run-test
70f0: 73 2a 20 68 65 64 20 30 29 29 0a 09 20 20 20 20 s* hed 0))..
7100: 3b 3b 20 67 65 74 74 69 6e 67 20 68 65 72 65 20 ;; getting here
7110: 6c 69 6b 65 6c 79 20 6d 65 61 6e 73 20 74 68 65 likely means the
7120: 20 73 79 73 74 65 6d 20 69 73 20 77 61 79 20 6f system is way o
7130: 76 65 72 6c 6f 61 64 65 64 2c 20 6b 69 6c 6c 20 verloaded, kill
7140: 61 20 66 75 6c 6c 20 6d 69 6e 75 74 65 20 62 65 a full minute be
7150: 66 6f 72 65 20 63 6f 6e 74 69 6e 75 69 6e 67 0a fore continuing.
7160: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 . (thread-sle
7170: 65 70 21 20 36 30 29 0a 09 20 20 20 20 3b 3b 20 ep! 60).. ;;
7180: 6e 75 6d 2d 72 65 74 72 69 65 73 20 63 6f 64 65 num-retries code
7190: 20 77 61 73 20 68 65 72 65 0a 09 20 20 20 20 3b was here.. ;
71a0: 3b 20 77 65 20 75 73 65 20 74 68 69 73 20 6f 70 ; we use this op
71b0: 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 6d 6f 76 portunity to mov
71c0: 65 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 72 65 e contents of re
71d0: 67 20 74 6f 20 74 61 6c 0a 09 20 20 20 20 28 6c g to tal.. (l
71e0: 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 ist (car newtal)
71f0: 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e 65 77 (append (cdr new
7200: 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 72 65 tal) reg) '() re
7210: 72 75 6e 73 29 29 20 3b 3b 20 61 6e 20 69 73 73 runs)) ;; an iss
7220: 75 65 20 77 69 74 68 20 70 72 65 72 65 71 73 20 ue with prereqs
7230: 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 20 20 not yet met?..
7240: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 (begin.. (deb
7250: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
7260: 22 6e 6f 20 66 61 69 6c 73 20 69 6e 20 70 72 65 "no fails in pre
7270: 72 65 71 75 69 73 69 74 65 73 20 66 6f 72 20 22 requisites for "
7280: 20 68 65 64 20 22 20 62 75 74 20 6e 6f 74 68 69 hed " but nothi
7290: 6e 67 20 73 65 65 6e 20 72 75 6e 6e 69 6e 67 20 ng seen running
72a0: 69 6e 20 61 20 77 68 69 6c 65 2c 20 64 72 6f 70 in a while, drop
72b0: 70 69 6e 67 20 74 65 73 74 20 22 20 68 65 64 20 ping test " hed
72c0: 22 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 20 71 " from the run q
72d0: 75 65 75 65 22 29 0a 09 20 20 20 20 28 6c 65 74 ueue").. (let
72e0: 20 28 28 74 65 73 74 2d 69 64 20 28 72 6d 74 3a ((test-id (rmt:
72f0: 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
7300: 69 64 20 68 65 64 20 22 22 29 29 29 0a 09 20 20 id hed "")))..
7310: 20 20 20 20 28 69 66 20 74 65 73 74 2d 69 64 20 (if test-id
7320: 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 (mt:test-set-sta
7330: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
7340: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 run-id test-id "
7350: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 54 49 NOT_STARTED" "TI
7360: 4d 45 44 5f 4f 55 54 22 20 22 4e 6f 74 68 69 6e MED_OUT" "Nothin
7370: 67 20 73 65 65 6e 20 72 75 6e 6e 69 6e 67 20 69 g seen running i
7380: 6e 20 61 20 77 68 69 6c 65 2e 22 29 29 29 0a 09 n a while.")))..
7390: 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a (list (runs:
73a0: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 queue-next-hed t
73b0: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
73c0: 67 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 gfull)... (runs
73d0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
73e0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
73f0: 65 67 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e egfull)... (run
7400: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
7410: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
7420: 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 72 65 72 regfull)... rer
7430: 75 6e 73 29 29 29 29 0a 0a 20 20 20 20 20 28 28 uns)))).. ((
7440: 61 6e 64 20 0a 20 20 20 20 20 20 20 28 6f 72 20 and . (or
7450: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (not (null? fail
7460: 73 29 29 0a 09 20 20 20 28 6e 6f 74 20 28 6e 75 s)).. (not (nu
7470: 6c 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 ll? prereq-fails
7480: 29 29 29 0a 20 20 20 20 20 20 20 28 6d 65 6d 62 ))). (memb
7490: 65 72 20 27 6e 6f 72 6d 61 6c 20 74 65 73 74 6d er 'normal testm
74a0: 6f 64 65 29 29 0a 20 20 20 20 20 20 28 64 65 62 ode)). (deb
74b0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
74c0: 22 74 65 73 74 20 22 20 20 68 65 64 20 22 20 28 "test " hed " (
74d0: 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 mode=" testmode
74e0: 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 70 72 ") has failed pr
74f0: 65 72 65 71 75 69 73 69 74 65 28 73 29 3b 20 22 erequisite(s); "
7500: 0a 09 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 ....(string-inte
7510: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
7520: 6d 62 64 61 20 28 74 29 28 63 6f 6e 63 20 28 64 mbda (t)(conc (d
7530: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
7540: 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 ame t) ":" (db:t
7550: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
7560: 22 2f 22 28 64 62 3a 74 65 73 74 2d 67 65 74 2d "/"(db:test-get-
7570: 73 74 61 74 75 73 20 74 29 29 29 20 66 61 69 6c status t))) fail
7580: 73 29 20 22 2c 20 22 29 0a 09 09 09 22 2c 20 72 s) ", ")....", r
7590: 65 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 emoving it from
75a0: 74 6f 2d 64 6f 20 6c 69 73 74 22 29 0a 20 20 20 to-do list").
75b0: 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 (let ((test-i
75c0: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
75d0: 69 64 20 72 75 6e 2d 69 64 20 68 65 64 20 22 22 id run-id hed ""
75e0: 29 29 29 0a 09 28 69 66 20 74 65 73 74 2d 69 64 )))..(if test-id
75f0: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
7600: 6e 75 6c 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 null? prereq-fai
7610: 6c 73 29 29 0a 09 09 28 6d 74 3a 74 65 73 74 2d ls))...(mt:test-
7620: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
7630: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
7640: 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 st-id "NOT_START
7650: 45 44 22 20 22 50 52 45 51 5f 44 49 53 43 41 52 ED" "PREQ_DISCAR
7660: 44 45 44 22 20 22 46 61 69 6c 65 64 20 74 6f 20 DED" "Failed to
7670: 72 75 6e 20 64 75 65 20 74 6f 20 70 72 69 6f 72 run due to prior
7680: 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 69 failed prerequi
7690: 73 69 74 65 73 22 29 0a 09 09 28 6d 74 3a 74 65 sites")...(mt:te
76a0: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
76b0: 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 tus-by-id run-id
76c0: 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 test-id "NOT_ST
76d0: 41 52 54 45 44 22 20 22 50 52 45 51 5f 46 41 49 ARTED" "PREQ_FAI
76e0: 4c 22 20 20 20 20 20 20 22 46 61 69 6c 65 64 20 L" "Failed
76f0: 74 6f 20 72 75 6e 20 64 75 65 20 74 6f 20 66 61 to run due to fa
7700: 69 6c 65 64 20 70 72 65 72 65 71 75 69 73 69 74 iled prerequisit
7710: 65 73 22 29 29 29 29 0a 20 20 20 20 20 20 28 69 es")))). (i
7720: 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
7730: 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 6c ? reg))(not (nul
7740: 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 28 62 65 l? tal))).. (be
7750: 67 69 6e 0a 09 20 20 20 20 28 68 61 73 68 2d 74 gin.. (hash-t
7760: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
7770: 65 67 69 73 74 72 79 20 68 65 64 20 27 43 41 4e egistry hed 'CAN
7780: 4e 4f 54 52 55 4e 29 0a 09 20 20 20 20 28 6c 69 NOTRUN).. (li
7790: 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e st (runs:queue-n
77a0: 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 ext-hed tal reg
77b0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
77c0: 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d .. (runs:queue-
77d0: 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 next-tal tal reg
77e0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
77f0: 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 ... (runs:queue
7800: 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 -next-reg tal re
7810: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
7820: 29 0a 09 09 20 20 28 63 6f 6e 73 20 68 65 64 20 )... (cons hed
7830: 72 65 72 75 6e 73 29 29 29 0a 09 20 20 23 66 29 reruns))).. #f)
7840: 29 20 3b 3b 20 23 66 20 66 6c 61 67 73 20 64 6f ) ;; #f flags do
7850: 20 6e 6f 74 20 6c 6f 6f 70 0a 0a 20 20 20 20 20 not loop..
7860: 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c ((and (not (null
7870: 3f 20 66 61 69 6c 73 29 29 28 6d 65 6d 62 65 72 ? fails))(member
7880: 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 'toplevel testm
7890: 6f 64 65 29 29 0a 20 20 20 20 20 20 28 69 66 20 ode)). (if
78a0: 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (or (not (null?
78b0: 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f reg))(not (null?
78c0: 20 74 61 6c 29 29 29 0a 09 20 20 20 28 6c 69 73 tal))).. (lis
78d0: 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 61 t (car newtal)(a
78e0: 70 70 65 6e 64 20 28 63 64 72 20 6e 65 77 74 61 ppend (cdr newta
78f0: 6c 29 20 72 65 67 29 20 27 28 29 20 72 65 72 75 l) reg) '() reru
7900: 6e 73 29 0a 09 20 20 23 66 29 29 20 0a 20 20 20 ns).. #f)) .
7910: 20 20 28 28 6e 75 6c 6c 3f 20 72 75 6e 6e 61 62 ((null? runnab
7920: 6c 65 73 29 20 23 66 29 20 3b 3b 20 69 66 20 77 les) #f) ;; if w
7930: 65 20 67 65 74 20 68 65 72 65 20 61 6e 64 20 6e e get here and n
7940: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 69 73 20 on-completed is
7950: 6e 75 6c 6c 20 74 68 65 20 69 74 27 73 20 61 6c null the it's al
7960: 6c 20 6f 76 65 72 2e 0a 20 20 20 20 20 28 65 6c l over.. (el
7970: 73 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a se. (debug:
7980: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
7990: 3a 20 46 41 49 4c 53 20 6f 72 20 69 6e 63 6f 6d : FAILS or incom
79a0: 70 6c 65 74 65 20 74 65 73 74 73 20 6d 61 79 62 plete tests mayb
79b0: 65 20 70 72 65 76 65 6e 74 69 6e 67 20 63 6f 6d e preventing com
79c0: 70 6c 65 74 69 6f 6e 20 6f 66 20 74 68 69 73 20 pletion of this
79d0: 72 75 6e 2e 20 57 61 74 63 68 20 66 6f 72 20 69 run. Watch for i
79e0: 73 73 75 65 73 20 77 69 74 68 20 74 65 73 74 20 ssues with test
79f0: 22 20 68 65 64 20 22 2c 20 63 6f 6e 74 69 6e 75 " hed ", continu
7a00: 69 6e 67 20 66 6f 72 20 6e 6f 77 22 29 0a 20 20 ing for now").
7a10: 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 28 72 75 ;; (list (ru
7a20: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
7a30: 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e d tal reg reglen
7a40: 20 72 65 67 66 75 6c 6c 29 0a 20 20 20 20 20 20 regfull).
7a50: 3b 3b 20 20 20 09 28 72 75 6e 73 3a 71 75 65 75 ;; .(runs:queu
7a60: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
7a70: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
7a80: 6c 29 0a 20 20 20 20 20 20 3b 3b 20 20 20 09 28 l). ;; .(
7a90: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
7aa0: 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c reg tal reg regl
7ab0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 20 20 en regfull).
7ac0: 20 20 3b 3b 20 20 20 09 72 65 72 75 6e 73 29 0a ;; .reruns).
7ad0: 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 (list (car
7ae0: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
7af0: 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 tal) reg reruns)
7b00: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
7b10: 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 2d 74 uns:mixed-list-t
7b20: 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 73 74 estname-and-test
7b30: 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 rec->list-of-str
7b40: 69 6e 67 73 20 69 6e 6c 73 74 29 0a 20 20 28 69 ings inlst). (i
7b50: 66 20 28 6e 75 6c 6c 3f 20 69 6e 6c 73 74 29 0a f (null? inlst).
7b60: 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 '().
7b70: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 (map (lambda (t)
7b80: 0a 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 .. (cond..
7b90: 20 20 20 20 28 28 76 65 63 74 6f 72 3f 20 74 29 ((vector? t)
7ba0: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
7bb0: 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 test-name (db:te
7bc0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
7bd0: 74 29 29 0a 09 09 20 20 20 20 20 28 69 74 65 6d t))... (item
7be0: 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
7bf0: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 29 29 et-item-path t))
7c00: 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 73 74 ... (test-st
7c10: 61 74 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ate (db:test-get
7c20: 2d 73 74 61 74 65 20 74 29 29 0a 09 09 20 20 20 -state t))...
7c30: 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 20 28 (test-status (
7c40: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
7c50: 75 73 20 74 29 29 29 0a 09 09 20 28 63 6f 6e 63 us t)))... (conc
7c60: 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 test-name (if (
7c70: 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 equal? item-path
7c80: 20 22 22 29 20 22 22 20 22 2f 22 29 20 69 74 65 "") "" "/") ite
7c90: 6d 2d 70 61 74 68 20 22 3a 22 20 74 65 73 74 2d m-path ":" test-
7ca0: 73 74 61 74 65 20 22 2f 22 20 74 65 73 74 2d 73 state "/" test-s
7cb0: 74 61 74 75 73 29 29 29 0a 09 20 20 20 20 20 20 tatus)))..
7cc0: 28 28 73 74 72 69 6e 67 3f 20 74 29 0a 09 20 20 ((string? t)..
7cd0: 20 20 20 20 20 74 29 0a 09 20 20 20 20 20 20 28 t).. (
7ce0: 65 6c 73 65 20 0a 09 20 20 20 20 20 20 20 28 63 else .. (c
7cf0: 6f 6e 63 20 74 29 29 29 29 0a 09 20 20 20 69 6e onc t)))).. in
7d00: 6c 73 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 lst)))..(define
7d10: 28 72 75 6e 73 3a 70 72 6f 63 65 73 73 2d 65 78 (runs:process-ex
7d20: 70 61 6e 64 65 64 2d 74 65 73 74 73 20 68 65 64 panded-tests hed
7d30: 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 20 tal reg reruns
7d40: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 20 74 reglen regfull t
7d50: 65 73 74 2d 72 65 63 6f 72 64 20 72 75 6e 6e 61 est-record runna
7d60: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
7d70: 6d 2d 70 61 74 68 20 6a 6f 62 67 72 6f 75 70 20 m-path jobgroup
7d80: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
7d90: 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 74 6f obs run-id waito
7da0: 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 ns item-path tes
7db0: 74 6d 6f 64 65 20 74 65 73 74 2d 70 61 74 74 73 tmode test-patts
7dc0: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
7dd0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 72 65 test-registry re
7de0: 67 69 73 74 72 79 2d 6d 75 74 65 78 20 66 6c 61 gistry-mutex fla
7df0: 67 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 2d 69 gs keyvals run-i
7e00: 6e 66 6f 20 6e 65 77 74 61 6c 20 61 6c 6c 2d 74 nfo newtal all-t
7e10: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 69 74 ests-registry it
7e20: 65 6d 6d 61 70 29 0a 20 20 28 6c 65 74 2a 20 28 emmap). (let* (
7e30: 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f (run-limits-info
7e40: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 (runs:c
7e50: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
7e60: 73 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 s run-id jobgrou
7e70: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
7e80: 2d 6a 6f 62 73 29 29 20 3b 3b 20 6c 6f 6f 6b 20 -jobs)) ;; look
7e90: 61 74 20 74 68 65 20 74 65 73 74 20 6a 6f 62 67 at the test jobg
7ea0: 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a 6f 62 roup and tot job
7eb0: 73 20 72 75 6e 6e 69 6e 67 0a 09 20 28 68 61 76 s running.. (hav
7ec0: 65 2d 72 65 73 6f 75 72 63 65 73 20 20 20 20 20 e-resources
7ed0: 20 20 20 20 20 28 63 61 72 20 72 75 6e 2d 6c 69 (car run-li
7ee0: 6d 69 74 73 2d 69 6e 66 6f 29 29 0a 09 20 28 6e mits-info)).. (n
7ef0: 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 um-running
7f00: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 (list-ref
7f10: 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f run-limits-info
7f20: 20 31 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 1)).. (num-runn
7f30: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
7f40: 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 (list-ref run-li
7f50: 6d 69 74 73 2d 69 6e 66 6f 20 32 29 29 20 0a 09 mits-info 2)) ..
7f60: 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 (max-concurrent
7f70: 2d 6a 6f 62 73 20 20 20 20 20 28 6c 69 73 74 2d -jobs (list-
7f80: 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 ref run-limits-i
7f90: 6e 66 6f 20 33 29 29 0a 09 20 28 6a 6f 62 2d 67 nfo 3)).. (job-g
7fa0: 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 roup-limit
7fb0: 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e (list-ref run
7fc0: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 34 29 29 -limits-info 4))
7fd0: 0a 09 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d .. (prereqs-not-
7fe0: 6d 65 74 20 20 20 20 20 20 20 20 20 28 72 6d 74 met (rmt
7ff0: 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 :get-prereqs-not
8000: 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 -met run-id wait
8010: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f ons item-path mo
8020: 64 65 3a 20 74 65 73 74 6d 6f 64 65 20 69 74 65 de: testmode ite
8030: 6d 6d 61 70 3a 20 69 74 65 6d 6d 61 70 29 29 0a mmap: itemmap)).
8040: 09 20 3b 3b 20 28 70 72 65 72 65 71 73 2d 6e 6f . ;; (prereqs-no
8050: 74 2d 6d 65 74 20 20 20 20 20 20 20 20 20 28 6d t-met (m
8060: 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 72 65 72 65 t:lazy-get-prere
8070: 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 qs-not-met run-i
8080: 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 d waitons item-p
8090: 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f ath mode: testmo
80a0: 64 65 20 69 74 65 6d 6d 61 70 3a 20 69 74 65 6d de itemmap: item
80b0: 6d 61 70 29 29 0a 09 20 28 66 61 69 6c 73 20 20 map)).. (fails
80c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80d0: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c (runs:calc-fail
80e0: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
80f0: 74 29 29 0a 09 20 28 6e 6f 6e 2d 63 6f 6d 70 6c t)).. (non-compl
8100: 65 74 65 64 20 20 20 20 20 20 20 20 20 20 20 28 eted (
8110: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
8120: 78 29 20 20 20 20 20 20 20 20 20 20 20 20 20 3b x) ;
8130: 3b 20 72 65 6d 6f 76 65 20 68 65 64 20 66 72 6f ; remove hed fro
8140: 6d 20 6e 6f 74 20 63 6f 6d 70 6c 65 74 65 64 20 m not completed
8150: 6c 69 73 74 2c 20 64 75 68 2c 20 6f 66 20 63 6f list, duh, of co
8160: 75 72 73 65 20 69 74 20 69 73 20 6e 6f 74 20 63 urse it is not c
8170: 6f 6d 70 6c 65 74 65 64 21 0a 09 09 09 09 09 20 ompleted!......
8180: 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (not (equal?
8190: 78 20 68 65 64 29 29 29 0a 09 09 09 09 09 20 20 x hed)))......
81a0: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
81b0: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
81c0: 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 20 28 6c -not-met))).. (l
81d0: 6f 6f 70 2d 6c 69 73 74 20 20 20 20 20 20 20 20 oop-list
81e0: 20 20 20 20 20 20 20 28 6c 69 73 74 20 68 65 64 (list hed
81f0: 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 29 tal reg reruns)
8200: 29 0a 09 20 3b 3b 20 63 6f 6e 66 69 67 75 72 65 ).. ;; configure
8210: 20 74 68 65 20 6c 6f 61 64 20 72 75 6e 6e 65 72 the load runner
8220: 0a 09 20 28 6e 75 6d 63 70 75 73 20 20 20 20 20 .. (numcpus
8230: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
8240: 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 73 mon:get-num-cpus
8250: 29 29 0a 09 20 28 6d 61 78 6c 6f 61 64 20 20 20 )).. (maxload
8260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
8270: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f tring->number (o
8280: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
8290: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
82a0: 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 6c 6f 61 obtools" "maxloa
82b0: 64 22 29 20 22 33 22 29 29 29 0a 09 20 28 77 61 d") "3"))).. (wa
82c0: 69 74 64 65 6c 61 79 20 20 20 20 20 20 20 20 20 itdelay
82d0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e (string->n
82e0: 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 umber (or (confi
82f0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
8300: 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 gdat* "jobtools"
8310: 20 22 77 61 69 74 64 65 6c 61 79 22 29 20 22 36 "waitdelay") "6
8320: 30 22 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 0")))). (debu
8330: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
8340: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 3a 20 have-resources:
8350: 22 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 " have-resources
8360: 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d " prereqs-not-m
8370: 65 74 3a 20 28 22 20 0a 09 09 20 20 20 20 20 20 et: (" ...
8380: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
8390: 72 73 65 20 0a 09 09 20 20 20 20 20 20 20 28 6d rse ... (m
83a0: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 ap (lambda (t)..
83b0: 09 09 20 20 20 20 20 20 28 69 66 20 28 76 65 63 .. (if (vec
83c0: 74 6f 72 3f 20 74 29 0a 09 09 09 09 20 20 28 63 tor? t)..... (c
83d0: 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 onc (db:test-get
83e0: 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 -state t) "/" (d
83f0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
8400: 73 20 74 29 29 0a 09 09 09 09 20 20 28 63 6f 6e s t))..... (con
8410: 63 20 22 20 57 41 52 4e 49 4e 47 3a 20 74 20 69 c " WARNING: t i
8420: 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 3d 22 s not a vector="
8430: 20 74 20 29 29 29 0a 09 09 09 20 20 20 20 70 72 t ))).... pr
8440: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 ereqs-not-met)..
8450: 09 20 20 20 20 20 20 20 22 2c 20 22 29 20 22 29 . ", ") ")
8460: 20 66 61 69 6c 73 3a 20 22 20 66 61 69 6c 73 0a fails: " fails.
8470: 09 09 20 20 20 20 20 20 20 22 5c 6e 72 65 67 69 .. "\nregi
8480: 73 74 65 72 65 64 3f 20 22 20 28 68 61 73 68 2d stered? " (hash-
8490: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
84a0: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
84b0: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
84c0: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
84d0: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 e item-path) #f)
84e0: 29 0a 09 09 09 20 20 20 20 0a 0a 20 20 20 20 0a ).... .. .
84f0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f (if (and (no
8500: 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 t (null? prereqs
8510: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 20 20 20 -not-met))..
8520: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
8530: 28 63 6f 6e 63 20 22 77 61 69 74 69 6e 67 20 6f (conc "waiting o
8540: 6e 20 74 65 73 74 73 20 22 20 70 72 65 72 65 71 n tests " prereq
8550: 73 2d 6e 6f 74 2d 6d 65 74 20 68 65 64 29 20 36 s-not-met hed) 6
8560: 30 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 0))..(debug:prin
8570: 74 2d 69 6e 66 6f 20 32 20 22 77 61 69 74 69 6e t-info 2 "waitin
8580: 67 20 6f 6e 20 74 65 73 74 73 3b 20 22 20 28 73 g on tests; " (s
8590: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
85a0: 65 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 e (runs:mixed-li
85b0: 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d st-testname-and-
85c0: 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 testrec->list-of
85d0: 2d 73 74 72 69 6e 67 73 20 70 72 65 72 65 71 73 -strings prereqs
85e0: 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 29 -not-met) ", "))
85f0: 29 0a 0a 20 20 20 20 3b 3b 20 44 6f 6e 27 74 20 ).. ;; Don't
8600: 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 74 69 6d know at this tim
8610: 65 20 69 66 20 74 68 65 20 74 65 73 74 20 68 61 e if the test ha
8620: 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 64 ve been launched
8630: 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 6e at some time in
8640: 20 74 68 65 20 70 61 73 74 0a 20 20 20 20 3b 3b the past. ;;
8650: 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 61 20 i.e. is this a
8660: 72 65 2d 6c 61 75 6e 63 68 3f 0a 20 20 20 20 28 re-launch?. (
8670: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
8680: 20 34 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 4 "run-limits-i
8690: 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d 69 nfo = " run-limi
86a0: 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 0a 20 20 ts-info). .
86b0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 0a 20 20 (cond. .
86c0: 20 20 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 6d ;; Check item
86d0: 20 70 61 74 68 20 61 67 61 69 6e 73 74 20 69 74 path against it
86e0: 65 6d 2d 70 61 74 74 73 2c 20 0a 20 20 20 20 20 em-patts, .
86f0: 3b 3b 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 74 ;;. ((not (t
8700: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
8710: 70 61 74 74 73 20 28 74 65 73 74 73 3a 74 65 73 patts (tests:tes
8720: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
8730: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 ame test-record)
8740: 20 69 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 item-path requi
8750: 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 red: required-te
8760: 73 74 73 29 29 20 3b 3b 20 54 68 69 73 20 74 65 sts)) ;; This te
8770: 73 74 2f 69 74 65 6d 70 61 74 68 20 69 73 20 6e st/itempath is n
8780: 6f 74 20 74 6f 20 62 65 20 72 75 6e 0a 20 20 20 ot to be run.
8790: 20 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 ;; else the r
87a0: 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 6d un is stuck, tem
87b0: 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 6d porarily or perm
87c0: 61 6e 65 6e 74 6c 79 0a 20 20 20 20 20 20 3b 3b anently. ;;
87d0: 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 63 but should chec
87e0: 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 74 k if it is due t
87f0: 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 o lack of resour
8800: 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 69 ces vs. prerequi
8810: 73 69 74 65 73 0a 20 20 20 20 20 20 28 64 65 62 sites. (deb
8820: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
8830: 22 53 6b 69 70 70 69 6e 67 20 22 20 28 74 65 73 "Skipping " (tes
8840: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
8850: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
8860: 65 63 6f 72 64 29 20 22 20 22 20 69 74 65 6d 2d ecord) " " item-
8870: 70 61 74 68 20 22 20 61 73 20 69 74 20 64 6f 65 path " as it doe
8880: 73 6e 27 74 20 6d 61 74 63 68 20 22 20 74 65 73 sn't match " tes
8890: 74 2d 70 61 74 74 73 29 0a 20 20 20 20 20 20 28 t-patts). (
88a0: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
88b0: 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 l? tal))(not (nu
88c0: 6c 6c 3f 20 72 65 67 29 29 29 0a 09 20 20 28 6c ll? reg))).. (l
88d0: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
88e0: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg
88f0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
8900: 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ...(runs:queue-n
8910: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
8920: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
8930: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
8940: 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 xt-reg tal reg r
8950: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
8960: 09 72 65 72 75 6e 73 29 0a 09 20 20 23 66 29 29 .reruns).. #f))
8970: 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 52 . . ;; R
8980: 65 67 69 73 74 65 72 20 74 65 73 74 73 20 0a 20 egister tests .
8990: 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 28 6e 6f ;;. ((no
89a0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
89b0: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
89c0: 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 egistry (db:test
89d0: 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
89e0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
89f0: 61 74 68 29 20 23 66 29 29 0a 20 20 20 20 20 20 ath) #f)).
8a00: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
8a10: 6f 20 34 20 22 50 72 65 2d 72 65 67 69 73 74 65 o 4 "Pre-registe
8a20: 72 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 ring test " test
8a30: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
8a40: 61 74 68 20 22 20 74 6f 20 63 72 65 61 74 65 20 ath " to create
8a50: 70 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 0a 20 placeholder" ).
8a60: 20 20 20 20 20 3b 3b 20 61 6c 77 61 79 73 20 64 ;; always d
8a70: 6f 20 66 69 72 6d 20 72 65 67 69 73 74 72 61 74 o firm registrat
8a80: 69 6f 6e 20 6e 6f 77 20 69 6e 20 76 31 2e 36 30 ion now in v1.60
8a90: 20 61 6e 64 20 67 72 65 61 74 65 72 20 3b 3b 20 and greater ;;
8aa0: 28 65 71 3f 20 2a 74 72 61 6e 73 70 6f 72 74 2d (eq? *transport-
8ab0: 74 79 70 65 2a 20 27 66 73 29 20 3b 3b 20 6e 6f type* 'fs) ;; no
8ac0: 20 70 6f 69 6e 74 20 69 6e 20 70 61 72 61 6c 6c point in parall
8ad0: 65 6c 20 72 65 67 69 73 74 72 61 74 69 6f 6e 20 el registration
8ae0: 69 66 20 75 73 65 20 66 73 0a 20 20 20 20 20 20 if use fs.
8af0: 28 6c 65 74 20 72 65 67 69 73 74 65 72 2d 6c 6f (let register-lo
8b00: 6f 70 20 28 28 6e 75 6d 74 72 69 65 73 20 31 35 op ((numtries 15
8b10: 29 29 0a 09 28 72 6d 74 3a 72 65 67 69 73 74 65 ))..(rmt:registe
8b20: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 r-test run-id te
8b30: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
8b40: 68 29 0a 09 28 69 66 20 28 72 6d 74 3a 67 65 74 h)..(if (rmt:get
8b50: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
8b60: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
8b70: 61 74 68 29 0a 09 20 20 20 20 28 68 61 73 68 2d ath).. (hash-
8b80: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
8b90: 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 registry (db:tes
8ba0: 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 t-make-full-name
8bb0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
8bc0: 70 61 74 68 29 20 27 64 6f 6e 65 29 0a 09 20 20 path) 'done)..
8bd0: 20 20 28 69 66 20 28 3e 20 6e 75 6d 74 72 69 65 (if (> numtrie
8be0: 73 20 30 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 s 0)...(begin...
8bf0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
8c00: 20 30 2e 35 29 0a 09 09 20 20 28 72 65 67 69 73 0.5)... (regis
8c10: 74 65 72 2d 6c 6f 6f 70 20 28 2d 20 6e 75 6d 74 ter-loop (- numt
8c20: 72 69 65 73 20 31 29 29 29 0a 09 09 28 64 65 62 ries 1)))...(deb
8c30: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
8c40: 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 72 65 67 R: failed to reg
8c50: 69 73 74 65 72 20 74 65 73 74 20 22 20 28 64 62 ister test " (db
8c60: 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
8c70: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
8c80: 74 65 6d 2d 70 61 74 68 29 29 29 29 29 0a 20 20 tem-path))))).
8c90: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
8ca0: 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ? (hash-table-re
8cb0: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
8cc0: 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 egistry (db:test
8cd0: 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
8ce0: 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 20 23 66 test-name "") #f
8cf0: 29 20 27 64 6f 6e 65 29 29 0a 09 20 20 28 62 65 ) 'done)).. (be
8d00: 67 69 6e 0a 09 20 20 20 20 28 72 6d 74 3a 72 65 gin.. (rmt:re
8d10: 67 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d gister-test run-
8d20: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 id test-name "")
8d30: 0a 09 20 20 20 20 28 69 66 20 28 72 6d 74 3a 67 .. (if (rmt:g
8d40: 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
8d50: 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 0a d test-name "").
8d60: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
8d70: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
8d80: 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 (db:test-make-f
8d90: 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 ull-name test-na
8da0: 6d 65 20 22 22 29 20 27 64 6f 6e 65 29 29 29 29 me "") 'done))))
8db0: 0a 20 20 20 20 20 20 28 72 75 6e 73 3a 73 68 72 . (runs:shr
8dc0: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
8dd0: 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 20 20 -tests-count)
8de0: 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 ;; DELAY TWEAKER
8df0: 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 (still needed?)
8e00: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
8e10: 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 75 6c 6c (null? tal)(null
8e20: 3f 20 72 65 67 29 29 0a 09 20 20 28 6c 69 73 74 ? reg)).. (list
8e30: 20 68 65 64 20 74 61 6c 20 28 61 70 70 65 6e 64 hed tal (append
8e40: 20 72 65 67 20 28 6c 69 73 74 20 68 65 64 29 29 reg (list hed))
8e50: 20 72 65 72 75 6e 73 29 0a 09 20 20 28 6c 69 73 reruns).. (lis
8e60: 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 t (runs:queue-ne
8e70: 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 xt-hed tal reg r
8e80: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
8e90: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
8ea0: 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 65 t-tal tal reg re
8eb0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
8ec0: 3b 3b 20 4e 42 2f 2f 20 48 65 72 65 20 77 65 20 ;; NB// Here we
8ed0: 61 72 65 20 62 75 69 6c 64 69 6e 67 20 72 65 67 are building reg
8ee0: 20 61 73 20 77 65 20 72 65 67 69 73 74 65 72 20 as we register
8ef0: 74 65 73 74 73 0a 09 09 3b 3b 20 69 66 20 72 65 tests...;; if re
8f00: 67 66 75 6c 6c 20 77 65 20 6d 75 73 74 20 70 6f gfull we must po
8f10: 70 20 74 68 65 20 66 72 6f 6e 74 20 69 74 65 6d p the front item
8f20: 20 6f 66 66 20 72 65 67 0a 09 09 28 69 66 20 72 off reg...(if r
8f30: 65 67 66 75 6c 6c 0a 09 09 20 20 20 20 28 61 70 egfull... (ap
8f40: 70 65 6e 64 20 28 63 64 72 20 72 65 67 29 20 28 pend (cdr reg) (
8f50: 6c 69 73 74 20 68 65 64 29 29 0a 09 09 20 20 20 list hed))...
8f60: 20 28 61 70 70 65 6e 64 20 72 65 67 20 28 6c 69 (append reg (li
8f70: 73 74 20 68 65 64 29 29 29 0a 09 09 72 65 72 75 st hed)))...reru
8f80: 6e 73 29 29 29 0a 20 20 20 20 20 0a 20 20 20 20 ns))). .
8f90: 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 6e ;; At this poin
8fa0: 74 20 68 65 64 20 74 65 73 74 20 72 65 67 69 73 t hed test regis
8fb0: 74 72 61 74 69 6f 6e 20 6d 75 73 74 20 62 65 20 tration must be
8fc0: 63 6f 6d 70 6c 65 74 65 64 2e 0a 20 20 20 20 20 completed..
8fd0: 3b 3b 0a 20 20 20 20 20 28 28 65 71 3f 20 28 68 ;;. ((eq? (h
8fe0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8ff0: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 fault test-regis
9000: 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b try (db:test-mak
9010: 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 e-full-name test
9020: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
9030: 20 23 66 29 0a 09 20 20 20 27 73 74 61 72 74 29 #f).. 'start)
9040: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
9050: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 74 int-info 0 "Wait
9060: 69 6e 67 20 6f 6e 20 74 65 73 74 20 72 65 67 69 ing on test regi
9070: 73 74 72 61 74 69 6f 6e 28 73 29 3a 20 22 0a 09 stration(s): "..
9080: 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 ..(string-inters
9090: 70 65 72 73 65 20 0a 09 09 09 20 28 66 69 6c 74 perse .... (filt
90a0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
90b0: 09 09 09 20 20 20 28 65 71 3f 20 28 68 61 73 68 ... (eq? (hash
90c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
90d0: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 lt test-registry
90e0: 20 78 20 23 66 29 20 27 73 74 61 72 74 29 29 0a x #f) 'start)).
90f0: 09 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 .... (hash-table
9100: 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 67 69 73 -keys test-regis
9110: 74 72 79 29 29 0a 09 09 09 20 22 2c 20 22 29 29 try)).... ", "))
9120: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
9130: 6c 65 65 70 21 20 30 2e 30 35 31 29 0a 20 20 20 leep! 0.051).
9140: 20 20 20 28 6c 69 73 74 20 68 65 64 20 74 61 6c (list hed tal
9150: 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a 20 20 reg reruns)).
9160: 20 20 20 0a 20 20 20 20 20 3b 3b 20 49 66 20 6e . ;; If n
9170: 6f 20 72 65 73 6f 75 72 63 65 73 20 61 72 65 20 o resources are
9180: 61 76 61 69 6c 61 62 6c 65 20 6a 75 73 74 20 6b available just k
9190: 69 6c 6c 20 74 69 6d 65 20 61 6e 64 20 6c 6f 6f ill time and loo
91a0: 70 20 61 67 61 69 6e 0a 20 20 20 20 20 3b 3b 0a p again. ;;.
91b0: 20 20 20 20 20 28 28 6e 6f 74 20 68 61 76 65 2d ((not have-
91c0: 72 65 73 6f 75 72 63 65 73 29 20 3b 3b 20 73 69 resources) ;; si
91d0: 6d 70 6c 79 20 74 72 79 20 61 67 61 69 6e 20 61 mply try again a
91e0: 66 74 65 72 20 77 61 69 74 69 6e 67 20 61 20 73 fter waiting a s
91f0: 65 63 6f 6e 64 0a 20 20 20 20 20 20 28 69 66 20 econd. (if
9200: 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 (runs:lownoise "
9210: 6e 6f 20 72 65 73 6f 75 72 63 65 73 22 20 36 30 no resources" 60
9220: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
9230: 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 72 65 73 t-info 1 "no res
9240: 6f 75 72 63 65 73 20 74 6f 20 72 75 6e 20 6e 65 ources to run ne
9250: 77 20 74 65 73 74 73 2c 20 77 61 69 74 69 6e 67 w tests, waiting
9260: 20 2e 2e 2e 22 29 29 0a 20 20 20 20 20 20 3b 3b ...")). ;;
9270: 20 48 61 76 65 20 67 6f 6e 65 20 62 61 63 6b 20 Have gone back
9280: 61 6e 64 20 66 6f 72 74 68 20 6f 6e 20 74 68 69 and forth on thi
9290: 73 20 62 75 74 20 64 62 20 73 74 61 72 76 61 74 s but db starvat
92a0: 69 6f 6e 20 69 73 20 61 6e 20 69 73 73 75 65 2e ion is an issue.
92b0: 0a 20 20 20 20 20 20 3b 3b 20 77 61 69 74 20 6f . ;; wait o
92c0: 6e 65 20 73 65 63 6f 6e 64 20 62 65 66 6f 72 65 ne second before
92d0: 20 6c 6f 6f 6b 69 6e 67 20 61 67 61 69 6e 20 74 looking again t
92e0: 6f 20 72 75 6e 20 6a 6f 62 73 2e 0a 20 20 20 20 o run jobs..
92f0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
9300: 20 31 29 0a 20 20 20 20 20 20 3b 3b 20 63 6f 75 1). ;; cou
9310: 6c 64 20 68 61 76 65 20 64 6f 6e 65 20 68 65 64 ld have done hed
9320: 20 74 61 6c 20 68 65 72 65 20 62 75 74 20 64 6f tal here but do
9330: 69 6e 67 20 63 61 72 2f 63 64 72 20 6f 66 20 6e ing car/cdr of n
9340: 65 77 74 61 6c 20 74 6f 20 72 6f 74 61 74 65 20 ewtal to rotate
9350: 74 65 73 74 73 0a 20 20 20 20 20 20 28 6c 69 73 tests. (lis
9360: 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 t (car newtal)(c
9370: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 dr newtal) reg r
9380: 65 72 75 6e 73 29 29 0a 20 20 20 20 20 0a 20 20 eruns)). .
9390: 20 20 20 3b 3b 20 54 68 69 73 20 69 73 20 74 68 ;; This is th
93a0: 65 20 66 69 6e 61 6c 20 73 74 61 67 65 2c 20 65 e final stage, e
93b0: 76 65 72 79 74 68 69 6e 67 20 69 73 20 69 6e 20 verything is in
93c0: 70 6c 61 63 65 20 73 6f 20 6c 61 75 6e 63 68 20 place so launch
93d0: 74 68 65 20 74 65 73 74 0a 20 20 20 20 20 3b 3b the test. ;;
93e0: 0a 20 20 20 20 20 28 28 61 6e 64 20 68 61 76 65 . ((and have
93f0: 2d 72 65 73 6f 75 72 63 65 73 0a 09 20 20 20 28 -resources.. (
9400: 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 or (null? prereq
9410: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 20 20 20 20 s-not-met)..
9420: 20 20 20 28 61 6e 64 20 28 6d 65 6d 62 65 72 20 (and (member
9430: 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 'toplevel testmo
9440: 64 65 29 20 3b 3b 20 20 27 74 6f 70 6c 65 76 65 de) ;; 'topleve
9450: 6c 29 0a 09 09 20 20 20 20 28 6e 75 6c 6c 3f 20 l)... (null?
9460: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 non-completed)))
9470: 29 0a 20 20 20 20 20 20 3b 3b 20 28 68 61 73 68 ). ;; (hash
9480: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 2a -table-delete! *
9490: 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 max-tries-hash*
94a0: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
94b0: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
94c0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 e item-path)).
94d0: 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 67 6f ;; we are go
94e0: 69 6e 67 20 74 6f 20 72 65 73 65 74 20 61 6c 6c ing to reset all
94f0: 20 74 68 65 20 63 6f 75 6e 74 65 72 73 20 66 6f the counters fo
9500: 72 20 74 65 73 74 20 72 65 74 72 69 65 73 20 62 r test retries b
9510: 79 20 73 65 74 74 69 6e 67 20 61 20 6e 65 77 20 y setting a new
9520: 68 61 73 68 20 74 61 62 6c 65 0a 20 20 20 20 20 hash table.
9530: 20 3b 3b 20 74 68 69 73 20 6d 65 61 6e 73 20 74 ;; this means t
9540: 68 65 79 20 77 69 6c 6c 20 69 6e 63 72 65 6d 65 hey will increme
9550: 6e 74 20 6f 6e 6c 79 20 77 68 65 6e 20 6e 6f 74 nt only when not
9560: 68 69 6e 67 20 63 61 6e 20 62 65 20 72 75 6e 0a hing can be run.
9570: 20 20 20 20 20 20 28 73 65 74 21 20 2a 6d 61 78 (set! *max
9580: 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 28 6d 61 -tries-hash* (ma
9590: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
95a0: 20 20 20 20 20 20 3b 3b 20 77 65 6c 6c 2c 20 66 ;; well, f
95b0: 69 72 73 74 20 6c 65 74 73 20 73 65 65 20 69 66 irst lets see if
95c0: 20 63 70 75 20 6c 6f 61 64 20 74 68 72 6f 74 74 cpu load thrott
95d0: 6c 69 6e 67 20 69 73 20 65 6e 61 62 6c 65 64 2e ling is enabled.
95e0: 20 49 66 20 73 6f 20 77 61 69 74 20 61 72 6f 75 If so wait arou
95f0: 6e 64 20 75 6e 74 69 6c 20 74 68 65 0a 20 20 20 nd until the.
9600: 20 20 20 3b 3b 20 61 76 65 72 61 67 65 20 63 70 ;; average cp
9610: 75 20 6c 6f 61 64 20 69 73 20 75 6e 64 65 72 20 u load is under
9620: 74 68 65 20 74 68 72 65 73 68 6f 6c 64 20 62 65 the threshold be
9630: 66 6f 72 65 20 63 6f 6e 74 69 6e 75 69 6e 67 0a fore continuing.
9640: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6e 66 69 (if (confi
9650: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
9660: 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 gdat* "jobtools"
9670: 20 22 6d 61 78 6c 6f 61 64 22 29 20 3b 3b 20 6f "maxload") ;; o
9680: 6e 6c 79 20 67 61 74 65 20 69 66 20 6d 61 78 6c nly gate if maxl
9690: 6f 61 64 20 69 73 20 73 70 65 63 69 66 69 65 64 oad is specified
96a0: 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 .. (common:wait
96b0: 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 -for-cpuload max
96c0: 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 load numcpus wai
96d0: 74 64 65 6c 61 79 29 29 0a 20 20 20 20 20 20 28 tdelay)). (
96e0: 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 run:test run-id
96f0: 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c 73 run-info keyvals
9700: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 runname test-re
9710: 63 6f 72 64 20 66 6c 61 67 73 20 23 66 20 74 65 cord flags #f te
9720: 73 74 2d 72 65 67 69 73 74 72 79 20 61 6c 6c 2d st-registry all-
9730: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a tests-registry).
9740: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
9750: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 e-set! test-regi
9760: 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 stry (db:test-ma
9770: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
9780: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
9790: 29 20 27 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 ) 'running).
97a0: 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 (runs:shrink-c
97b0: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
97c0: 73 2d 63 6f 75 6e 74 29 20 20 3b 3b 20 44 45 4c s-count) ;; DEL
97d0: 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c AY TWEAKER (stil
97e0: 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 20 l needed?).
97f0: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
9800: 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 p! *global-delta
9810: 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 *). (if (or
9820: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
9830: 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 ))(not (null? re
9840: 67 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 72 g))).. (list (r
9850: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
9860: 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 ed tal reg regle
9870: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 n regfull)...(ru
9880: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 ns:queue-next-ta
9890: 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e l tal reg reglen
98a0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e regfull)...(run
98b0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
98c0: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
98d0: 72 65 67 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e regfull)...rerun
98e0: 73 29 0a 09 20 20 23 66 29 29 0a 20 20 20 20 20 s).. #f)).
98f0: 0a 20 20 20 20 20 3b 3b 20 6d 75 73 74 20 62 65 . ;; must be
9900: 20 77 65 20 68 61 76 65 20 75 6e 6d 65 74 20 70 we have unmet p
9910: 72 65 72 65 71 75 69 73 69 74 65 73 0a 20 20 20 rerequisites.
9920: 20 20 3b 3b 0a 20 20 20 20 20 28 65 6c 73 65 0a ;;. (else.
9930: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9940: 6e 74 20 34 20 22 46 41 49 4c 53 3a 20 22 20 66 nt 4 "FAILS: " f
9950: 61 69 6c 73 29 0a 20 20 20 20 20 20 3b 3b 20 49 ails). ;; I
9960: 66 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 20 6f 66 f one or more of
9970: 20 74 68 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 the prereqs-not
9980: 2d 6d 65 74 20 61 72 65 20 46 41 49 4c 20 74 68 -met are FAIL th
9990: 65 6e 20 77 65 20 63 61 6e 20 69 73 73 75 65 0a en we can issue.
99a0: 20 20 20 20 20 20 3b 3b 20 61 20 6d 65 73 73 61 ;; a messa
99b0: 67 65 20 61 6e 64 20 64 72 6f 70 20 68 65 64 20 ge and drop hed
99c0: 66 72 6f 6d 20 74 68 65 20 69 74 65 6d 73 20 74 from the items t
99d0: 6f 20 62 65 20 70 72 6f 63 65 73 73 65 64 2e 0a o be processed..
99e0: 20 20 20 20 20 20 3b 3b 20 28 72 75 6e 73 3a 6d ;; (runs:m
99f0: 69 78 65 64 2d 6c 69 73 74 2d 74 65 73 74 6e 61 ixed-list-testna
9a00: 6d 65 2d 61 6e 64 2d 74 65 73 74 72 65 63 2d 3e me-and-testrec->
9a10: 6c 69 73 74 2d 6f 66 2d 73 74 72 69 6e 67 73 20 list-of-strings
9a20: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
9a30: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
9a40: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 (not (null? prer
9a50: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 eqs-not-met))..
9a60: 20 20 20 20 20 20 28 72 75 6e 73 3a 6c 6f 77 6e (runs:lown
9a70: 6f 69 73 65 20 28 63 6f 6e 63 20 22 77 61 69 74 oise (conc "wait
9a80: 69 6e 67 20 6f 6e 20 74 65 73 74 73 20 22 20 70 ing on tests " p
9a90: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 68 rereqs-not-met h
9aa0: 65 64 29 20 36 30 29 29 0a 09 20 20 28 64 65 62 ed) 60)).. (deb
9ab0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
9ac0: 22 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 "waiting on test
9ad0: 73 3b 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 s; " (string-int
9ae0: 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 ersperse .......
9af0: 20 20 20 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d (runs:mixed-
9b00: 6c 69 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e list-testname-an
9b10: 64 2d 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d d-testrec->list-
9b20: 6f 66 2d 73 74 72 69 6e 67 73 20 0a 09 09 09 09 of-strings .....
9b30: 09 09 20 20 20 20 20 70 72 65 72 65 71 73 2d 6e .. prereqs-n
9b40: 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 29 29 0a ot-met) ", "))).
9b50: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
9b60: 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 20 20 20 ull? fails)..
9b70: 20 20 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c (member 'topl
9b80: 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 29 0a evel testmode)).
9b90: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b . (begin.. ;
9ba0: 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 ; couldn't run,
9bb0: 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a take a breather.
9bc0: 09 20 20 20 20 28 69 66 20 20 28 72 75 6e 73 3a . (if (runs:
9bd0: 6c 6f 77 6e 6f 69 73 65 20 22 57 61 69 74 69 6e lownoise "Waitin
9be0: 67 20 66 6f 72 20 6d 6f 72 65 20 77 6f 72 6b 20 g for more work
9bf0: 74 6f 20 64 6f 2e 2e 2e 22 20 36 30 29 0a 09 09 to do..." 60)...
9c00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
9c10: 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 66 6f fo 0 "Waiting fo
9c20: 72 20 6d 6f 72 65 20 77 6f 72 6b 20 74 6f 20 64 r more work to d
9c30: 6f 2e 2e 2e 22 29 29 0a 09 20 20 20 20 28 74 68 o...")).. (th
9c40: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 read-sleep! 1)..
9c50: 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 20 6e (list (car n
9c60: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
9c70: 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a l) reg reruns)).
9c80: 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e . ;; the waiton
9c90: 20 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f 20 70 is FAIL so no p
9ca0: 6f 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 20 74 oint in trying t
9cb0: 6f 20 72 75 6e 20 68 65 64 20 65 76 65 72 20 61 o run hed ever a
9cc0: 67 61 69 6e 0a 09 20 20 28 69 66 20 28 6f 72 20 gain.. (if (or
9cd0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
9ce0: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
9cf0: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ))).. (if (
9d00: 76 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 09 20 vector? hed)...
9d10: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 (begin... (d
9d20: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 ebug:print 1 "WA
9d30: 52 4e 49 4e 47 3a 20 44 72 6f 70 70 69 6e 67 20 RNING: Dropping
9d40: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
9d50: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 "/" item-path..
9d60: 09 09 09 20 22 20 66 72 6f 6d 20 74 68 65 20 6c ... " from the l
9d70: 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 69 74 aunch list as it
9d80: 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 65 has prerequiste
9d90: 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c 22 s that are FAIL"
9da0: 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 )... (let ((t
9db0: 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d est-id (rmt:get-
9dc0: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 68 test-id run-id h
9dd0: 65 64 20 22 22 29 29 29 0a 09 09 20 20 20 20 20 ed "")))...
9de0: 20 28 69 66 20 74 65 73 74 2d 69 64 20 28 6d 74 (if test-id (mt
9df0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
9e00: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
9e10: 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 -id test-id "NOT
9e20: 5f 53 54 41 52 54 45 44 22 20 22 50 52 45 51 5f _STARTED" "PREQ_
9e30: 46 41 49 4c 22 20 22 46 61 69 6c 65 64 20 74 6f FAIL" "Failed to
9e40: 20 72 75 6e 20 64 75 65 20 74 6f 20 66 61 69 6c run due to fail
9e50: 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 73 ed prerequisites
9e60: 22 29 29 29 0a 09 09 20 20 20 20 28 72 75 6e 73 ")))... (runs
9e70: 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d :shrink-can-run-
9e80: 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 more-tests-count
9e90: 29 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b ) ;; DELAY TWEAK
9ea0: 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 ER (still needed
9eb0: 3f 29 0a 09 09 20 20 20 20 3b 3b 20 28 74 68 72 ?)... ;; (thr
9ec0: 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 ead-sleep! *glob
9ed0: 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 20 20 al-delta*)...
9ee0: 20 3b 3b 20 54 68 69 73 20 6e 65 78 74 20 69 73 ;; This next is
9ef0: 20 66 6f 72 20 74 68 65 20 69 74 65 6d 73 0a 09 for the items..
9f00: 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 . (mt:test-se
9f10: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
9f20: 79 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 y-testname run-i
9f30: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
9f40: 2d 70 61 74 68 20 22 4e 4f 54 5f 53 54 41 52 54 -path "NOT_START
9f50: 45 44 22 20 22 42 4c 4f 43 4b 45 44 22 20 23 66 ED" "BLOCKED" #f
9f60: 29 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 )... (hash-ta
9f70: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
9f80: 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d gistry (db:test-
9f90: 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 make-full-name t
9fa0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
9fb0: 74 68 29 20 27 72 65 6d 6f 76 65 64 29 0a 09 09 th) 'removed)...
9fc0: 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a (list (runs:
9fd0: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 queue-next-hed t
9fe0: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
9ff0: 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 72 75 6e gfull).... (run
a000: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
a010: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
a020: 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 72 regfull).... (r
a030: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 uns:queue-next-r
a040: 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 eg tal reg regle
a050: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
a060: 72 65 72 75 6e 73 20 3b 3b 20 57 41 53 3a 20 28 reruns ;; WAS: (
a070: 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 29 cons hed reruns)
a080: 20 3b 3b 20 62 75 74 20 74 68 61 74 20 6d 61 6b ;; but that mak
a090: 65 73 20 6e 6f 20 73 65 6e 73 65 3f 0a 09 09 09 es no sense?....
a0a0: 20 20 29 29 0a 09 09 20 20 28 6c 65 74 20 28 28 ))... (let ((
a0b0: 6e 74 68 2d 74 72 79 20 28 68 61 73 68 2d 74 61 nth-try (hash-ta
a0c0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
a0d0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 65 test-registry he
a0e0: 64 20 30 29 29 29 0a 09 09 20 20 20 20 28 63 6f d 0)))... (co
a0f0: 6e 64 0a 09 09 20 20 20 20 20 28 28 6d 65 6d 62 nd... ((memb
a100: 65 72 20 22 52 55 4e 4e 49 4e 47 22 20 28 6d 61 er "RUNNING" (ma
a110: 70 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 p db:test-get-st
a120: 61 74 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ate prereqs-not-
a130: 6d 65 74 29 29 0a 09 09 20 20 20 20 20 20 28 69 met))... (i
a140: 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 f (runs:lownoise
a150: 20 28 63 6f 6e 63 20 22 70 6f 73 73 69 62 6c 65 (conc "possible
a160: 20 52 55 4e 4e 49 4e 47 20 70 72 65 72 65 71 75 RUNNING prerequ
a170: 69 73 74 65 73 20 22 20 68 65 64 29 20 36 30 29 istes " hed) 60)
a180: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
a190: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 nt 0 "WARNING: t
a1a0: 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 est " hed " has
a1b0: 70 6f 73 73 69 62 6c 65 20 52 55 4e 4e 49 4e 47 possible RUNNING
a1c0: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 2c 20 prerequisites,
a1d0: 64 6f 6e 27 74 20 67 69 76 65 20 75 70 20 6f 6e don't give up on
a1e0: 20 69 74 20 79 65 74 2e 22 29 29 0a 09 09 20 20 it yet."))...
a1f0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
a200: 70 21 20 34 29 0a 09 09 20 20 20 20 20 20 28 6c p! 4)... (l
a210: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
a220: 6e 65 78 74 2d 68 65 64 20 6e 65 77 74 61 6c 20 next-hed newtal
a230: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
a240: 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 ll).... (runs
a250: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
a260: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
a270: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
a280: 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 (runs:queue-ne
a290: 78 74 2d 72 65 67 20 6e 65 77 74 61 6c 20 72 65 xt-reg newtal re
a2a0: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
a2b0: 29 0a 09 09 09 20 20 20 20 72 65 72 75 6e 73 29 ).... reruns)
a2c0: 29 0a 09 09 20 20 20 20 20 28 28 6f 72 20 28 6e )... ((or (n
a2d0: 6f 74 20 6e 74 68 2d 74 72 79 29 0a 09 09 09 20 ot nth-try)....
a2e0: 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 6e (and (number? n
a2f0: 74 68 2d 74 72 79 29 0a 09 09 09 20 20 20 20 20 th-try)....
a300: 20 20 28 3c 20 6e 74 68 2d 74 72 79 20 31 30 29 (< nth-try 10)
a310: 29 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 ))... (hash
a320: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
a330: 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 28 69 -registry hed (i
a340: 66 20 28 6e 75 6d 62 65 72 3f 20 6e 74 68 2d 74 f (number? nth-t
a350: 72 79 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 ry)........
a360: 28 2b 20 6e 74 68 2d 74 72 79 20 31 29 0a 09 09 (+ nth-try 1)...
a370: 09 09 09 09 09 20 20 20 20 20 30 29 29 0a 09 09 ..... 0))...
a380: 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a (if (runs:
a390: 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 lownoise (conc "
a3a0: 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 74 65 73 not removing tes
a3b0: 74 20 22 20 68 65 64 29 20 36 30 29 0a 09 09 09 t " hed) 60)....
a3c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
a3d0: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 72 "WARNING: not r
a3e0: 65 6d 6f 76 69 6e 67 20 74 65 73 74 20 22 20 68 emoving test " h
a3f0: 65 64 20 22 20 66 72 6f 6d 20 71 75 65 75 65 20 ed " from queue
a400: 61 6c 74 68 6f 75 67 68 20 69 74 20 6d 61 79 20 although it may
a410: 6e 6f 74 20 62 65 20 72 75 6e 6e 61 62 6c 65 20 not be runnable
a420: 64 75 65 20 74 6f 20 46 41 49 4c 45 44 20 70 72 due to FAILED pr
a430: 65 72 65 71 75 69 73 69 74 65 73 22 29 29 0a 09 erequisites"))..
a440: 09 20 20 20 20 20 20 3b 3b 20 6d 61 79 20 6e 6f . ;; may no
a450: 74 20 68 61 76 65 20 70 72 6f 63 65 73 73 65 64 t have processed
a460: 20 63 6f 72 72 65 63 74 6c 79 2e 20 43 6f 75 6c correctly. Coul
a470: 64 20 62 65 20 61 20 72 61 63 65 20 63 6f 6e 64 d be a race cond
a480: 69 74 69 6f 6e 20 69 6e 20 79 6f 75 72 20 74 65 ition in your te
a490: 73 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f st implementatio
a4a0: 6e 3f 20 44 72 6f 70 70 69 6e 67 20 74 65 73 74 n? Dropping test
a4b0: 20 22 20 68 65 64 29 20 3b 3b 20 20 22 20 61 73 " hed) ;; " as
a4c0: 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 it has prerequi
a4d0: 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 stes that are FA
a4e0: 49 4c 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 69 IL. (NOTE: hed i
a4f0: 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 22 s not a vector)"
a500: 29 0a 09 09 20 20 20 20 20 20 28 72 75 6e 73 3a )... (runs:
a510: 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d shrink-can-run-m
a520: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 ore-tests-count)
a530: 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 ;; DELAY TWEAKE
a540: 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f R (still needed?
a550: 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 6c 69 )... ;; (li
a560: 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 st hed tal reg r
a570: 65 72 75 6e 73 29 0a 09 09 20 20 20 20 20 20 3b eruns)... ;
a580: 3b 20 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 ; (list (car new
a590: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
a5a0: 20 72 65 67 20 72 65 72 75 6e 73 29 0a 09 09 20 reg reruns)...
a5b0: 20 20 20 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 ;; (hash-ta
a5c0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
a5d0: 67 69 73 74 72 79 20 68 65 64 20 27 72 65 6d 6f gistry hed 'remo
a5e0: 76 65 64 29 0a 09 09 20 20 20 20 20 20 28 6c 69 ved)... (li
a5f0: 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e st (runs:queue-n
a600: 65 78 74 2d 68 65 64 20 6e 65 77 74 61 6c 20 72 ext-hed newtal r
a610: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
a620: 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 3a l).... (runs:
a630: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 6e queue-next-tal n
a640: 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e ewtal reg reglen
a650: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 regfull)....
a660: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
a670: 74 2d 72 65 67 20 6e 65 77 74 61 6c 20 72 65 67 t-reg newtal reg
a680: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
a690: 0a 09 09 09 20 20 20 20 72 65 72 75 6e 73 29 29 .... reruns))
a6a0: 0a 09 09 20 20 20 20 20 28 28 73 79 6d 62 6f 6c ... ((symbol
a6b0: 3f 20 6e 74 68 2d 74 72 79 29 0a 09 09 20 20 20 ? nth-try)...
a6c0: 20 20 20 28 69 66 20 28 65 71 3f 20 6e 74 68 2d (if (eq? nth-
a6d0: 74 72 79 20 27 72 65 6d 6f 76 65 64 29 20 3b 3b try 'removed) ;;
a6e0: 20 72 65 6d 6f 76 65 64 20 69 73 20 72 65 6d 6f removed is remo
a6f0: 76 65 64 20 2d 20 64 72 6f 70 20 69 74 20 4e 4f ved - drop it NO
a700: 57 0a 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c W.... (if (null
a710: 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 20 20 20 ? tal)....
a720: 23 66 20 3b 3b 20 79 65 73 2c 20 72 65 61 6c 6c #f ;; yes, reall
a730: 79 0a 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 y.... (list
a740: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
a750: 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 al) reg reruns))
a760: 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
a770: 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f (if (runs:lo
a780: 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 46 41 wnoise (conc "FA
a790: 49 4c 45 44 20 70 72 65 72 65 71 75 69 73 69 74 ILED prerequisit
a7a0: 65 73 20 6f 72 20 6f 74 68 65 72 20 69 73 73 75 es or other issu
a7b0: 65 22 20 68 65 64 29 20 36 30 29 0a 09 09 09 09 e" hed) 60).....
a7c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
a7d0: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 WARNING: test "
a7e0: 68 65 64 20 22 20 68 61 73 20 46 41 49 4c 45 44 hed " has FAILED
a7f0: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 6f prerequisites o
a800: 72 20 6f 74 68 65 72 20 69 73 73 75 65 2e 20 49 r other issue. I
a810: 6e 74 65 72 6e 61 6c 20 73 74 61 74 65 20 22 20 nternal state "
a820: 6e 74 68 2d 74 72 79 20 22 20 77 69 6c 6c 20 62 nth-try " will b
a830: 65 20 6f 76 65 72 72 69 64 64 65 6e 20 61 6e 64 e overridden and
a840: 20 77 65 27 6c 6c 20 72 65 74 72 79 2e 22 29 29 we'll retry."))
a850: 0a 09 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 .... (mt:test
a860: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
a870: 73 2d 62 79 2d 74 65 73 74 6e 61 6d 65 20 72 75 s-by-testname ru
a880: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
a890: 74 65 6d 2d 70 61 74 68 20 22 4e 4f 54 5f 53 54 tem-path "NOT_ST
a8a0: 41 52 54 45 44 22 20 22 4b 45 45 50 5f 54 52 59 ARTED" "KEEP_TRY
a8b0: 49 4e 47 22 20 23 66 29 0a 09 09 09 20 20 20 20 ING" #f)....
a8c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
a8d0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 test-registry h
a8e0: 65 64 20 30 29 0a 09 09 09 20 20 20 20 28 6c 69 ed 0).... (li
a8f0: 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e st (runs:queue-n
a900: 65 78 74 2d 68 65 64 20 6e 65 77 74 61 6c 20 72 ext-hed newtal r
a910: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
a920: 6c 29 0a 09 09 09 09 20 20 28 72 75 6e 73 3a 71 l)..... (runs:q
a930: 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 6e 65 ueue-next-tal ne
a940: 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 wtal reg reglen
a950: 72 65 67 66 75 6c 6c 29 0a 09 09 09 09 20 20 28 regfull)..... (
a960: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
a970: 72 65 67 20 6e 65 77 74 61 6c 20 72 65 67 20 72 reg newtal reg r
a980: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
a990: 09 09 09 20 20 72 65 72 75 6e 73 29 29 29 29 0a ... reruns)))).
a9a0: 09 09 20 20 20 20 20 28 65 6c 73 65 0a 09 09 20 .. (else...
a9b0: 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c (if (runs:l
a9c0: 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 46 ownoise (conc "F
a9d0: 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 74 65 AILED prerequite
a9e0: 73 74 73 20 61 6e 64 20 77 65 20 74 72 69 65 64 sts and we tried
a9f0: 22 20 68 65 64 29 20 36 30 29 0a 09 09 09 20 20 " hed) 60)....
aa00: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
aa10: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 WARNING: test "
aa20: 68 65 64 20 22 20 68 61 73 20 46 41 49 4c 45 44 hed " has FAILED
aa30: 20 70 72 65 72 65 71 75 69 74 65 73 74 73 20 61 prerequitests a
aa40: 6e 64 20 77 65 27 76 65 20 74 72 69 65 64 20 61 nd we've tried a
aa50: 74 20 6c 65 61 73 74 20 31 30 20 74 69 6d 65 73 t least 10 times
aa60: 20 74 6f 20 72 75 6e 20 69 74 2e 20 47 69 76 69 to run it. Givi
aa70: 6e 67 20 75 70 20 6e 6f 77 2e 22 29 29 0a 09 09 ng up now."))...
aa80: 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a ;; (debug:
aa90: 70 72 69 6e 74 20 30 20 22 20 20 20 20 20 20 20 print 0 "
aaa0: 20 20 70 72 65 72 65 71 73 3a 20 22 20 70 72 65 prereqs: " pre
aab0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 reqs-not-met)...
aac0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
aad0: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 e-set! test-regi
aae0: 73 74 72 79 20 68 65 64 20 27 72 65 6d 6f 76 65 stry hed 'remove
aaf0: 64 29 0a 09 09 20 20 20 20 20 20 28 6d 74 3a 74 d)... (mt:t
ab00: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
ab10: 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d 65 atus-by-testname
ab20: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
ab30: 65 20 69 74 65 6d 2d 70 61 74 68 20 22 4e 4f 54 e item-path "NOT
ab40: 5f 53 54 41 52 54 45 44 22 20 22 54 45 4e 5f 53 _STARTED" "TEN_S
ab50: 54 52 49 4b 45 53 22 20 23 66 29 0a 09 09 20 20 TRIKES" #f)...
ab60: 20 20 20 20 3b 3b 20 49 27 6d 20 75 6e 63 6c 65 ;; I'm uncle
ab70: 61 72 20 6f 6e 20 69 66 20 74 68 69 73 20 72 6f ar on if this ro
ab80: 6c 6c 20 75 70 20 69 73 20 6e 65 65 64 65 64 20 ll up is needed
ab90: 2d 20 69 74 20 6d 61 79 20 62 65 20 74 68 65 20 - it may be the
aba0: 72 6f 6f 74 20 63 61 75 73 65 20 6f 66 20 74 68 root cause of th
abb0: 65 20 22 61 6c 6c 20 73 65 74 20 74 6f 20 46 41 e "all set to FA
abc0: 49 4c 22 20 62 75 67 2e 0a 09 09 20 20 20 20 20 IL" bug....
abd0: 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 (rmt:roll-up-pa
abe0: 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 ss-fail-counts r
abf0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
ac00: 69 74 65 6d 2d 70 61 74 68 20 23 66 20 22 46 41 item-path #f "FA
ac10: 49 4c 22 29 20 3b 3b 20 74 72 65 61 74 20 61 73 IL") ;; treat as
ac20: 20 46 41 49 4c 0a 09 09 20 20 20 20 20 20 28 6c FAIL... (l
ac30: 69 73 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 ist (if (null? t
ac40: 61 6c 29 28 63 61 72 20 6e 65 77 74 61 6c 29 28 al)(car newtal)(
ac50: 63 61 72 20 74 61 6c 29 29 0a 09 09 09 20 20 20 car tal))....
ac60: 20 74 61 6c 0a 09 09 09 20 20 20 20 72 65 67 0a tal.... reg.
ac70: 09 09 09 20 20 20 20 72 65 72 75 6e 73 29 29 29 ... reruns)))
ac80: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 63 61 6e )).. ;; can
ac90: 27 74 20 64 72 6f 70 20 74 68 69 73 20 2d 20 6d 't drop this - m
aca0: 61 79 62 65 20 72 75 6e 6e 69 6e 67 3f 20 4a 75 aybe running? Ju
acb0: 73 74 20 6b 65 65 70 20 74 72 79 69 6e 67 0a 09 st keep trying..
acc0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e (let ((run
acd0: 61 62 6c 65 2d 74 65 73 74 73 20 28 72 75 6e 73 able-tests (runs
ace0: 3a 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 20 70 :runable-tests p
acf0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
ad00: 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 72 )...(if (null? r
ad10: 75 6e 61 62 6c 65 2d 74 65 73 74 73 29 0a 09 09 unable-tests)...
ad20: 20 20 20 20 23 66 20 20 20 3b 3b 20 49 20 74 68 #f ;; I th
ad30: 69 6e 6b 20 77 65 20 61 72 65 20 74 72 75 6c 79 ink we are truly
ad40: 20 64 6f 6e 65 20 68 65 72 65 0a 09 09 20 20 20 done here...
ad50: 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 (list (runs:que
ad60: 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e 65 77 74 ue-next-hed newt
ad70: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
ad80: 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 gfull).... (r
ad90: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 uns:queue-next-t
ada0: 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 al newtal reg re
adb0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
adc0: 09 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 . (runs:queue
add0: 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 74 61 6c -next-reg newtal
ade0: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
adf0: 75 6c 6c 29 0a 09 09 09 20 20 20 20 72 65 72 75 ull).... reru
ae00: 6e 73 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 ns)))))))))..;;
ae10: 73 63 61 6e 20 61 20 6c 69 73 74 20 6f 66 20 74 scan a list of t
ae20: 65 73 74 73 20 6c 6f 6f 6b 69 6e 67 20 74 6f 20 ests looking to
ae30: 73 65 65 20 69 66 20 61 6e 79 20 61 72 65 20 70 see if any are p
ae40: 6f 74 65 6e 74 69 61 6c 6c 79 20 72 75 6e 6e 61 otentially runna
ae50: 62 6c 65 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ble.(define (run
ae60: 73 3a 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 20 s:runable-tests
ae70: 74 65 73 74 73 29 0a 20 20 28 66 69 6c 74 65 72 tests). (filter
ae80: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 20 (lambda (t)..
ae90: 20 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 (if (not (vect
aea0: 6f 72 3f 20 74 29 29 0a 09 09 74 0a 09 09 28 6c or? t))...t...(l
aeb0: 65 74 20 28 28 73 74 61 74 65 20 20 28 64 62 3a et ((state (db:
aec0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
aed0: 29 29 0a 09 09 20 20 20 20 20 20 28 73 74 61 74 ))... (stat
aee0: 75 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d us (db:test-get-
aef0: 73 74 61 74 75 73 20 74 29 29 29 0a 09 09 20 20 status t)))...
af00: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
af10: 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a 09 09 20 ymbol state)...
af20: 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 20 49 ((COMPLETED I
af30: 4e 43 4f 4d 50 4c 45 54 45 29 20 23 66 29 0a 09 NCOMPLETE) #f)..
af40: 09 20 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 . ((NOT_START
af50: 45 44 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 ED)... (if (
af60: 6d 65 6d 62 65 72 20 73 74 61 74 75 73 20 27 28 member status '(
af70: 22 54 45 4e 5f 53 54 52 49 4b 45 53 22 20 22 42 "TEN_STRIKES" "B
af80: 4c 4f 43 4b 45 44 22 20 22 50 52 45 51 5f 46 41 LOCKED" "PREQ_FA
af90: 49 4c 22 20 22 5a 45 52 4f 5f 49 54 45 4d 53 22 IL" "ZERO_ITEMS"
afa0: 20 22 50 52 45 51 5f 44 49 53 43 41 52 44 45 44 "PREQ_DISCARDED
afb0: 22 20 22 54 49 4d 45 44 5f 4f 55 54 22 20 29 29 " "TIMED_OUT" ))
afc0: 0a 09 09 09 20 23 66 0a 09 09 09 20 74 29 29 0a .... #f.... t)).
afd0: 09 09 20 20 20 20 28 28 44 45 4c 45 54 45 44 29 .. ((DELETED)
afe0: 20 23 66 29 0a 09 09 20 20 20 20 28 65 6c 73 65 #f)... (else
aff0: 20 74 29 29 29 29 29 0a 09 20 20 74 65 73 74 73 t))))).. tests
b000: 29 29 0a 0a 3b 3b 20 65 76 65 72 79 20 74 69 6d ))..;; every tim
b010: 65 20 74 68 6f 75 67 68 20 74 68 65 20 6c 6f 6f e though the loo
b020: 70 20 69 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 p increment the
b030: 74 65 73 74 2f 69 74 65 6d 70 61 74 74 20 76 61 test/itempatt va
b040: 6c 2e 0a 3b 3b 20 77 68 65 6e 20 74 68 65 20 6d l..;; when the m
b050: 69 6e 20 69 73 20 3e 20 6d 61 78 2d 61 6c 6c 6f in is > max-allo
b060: 77 65 64 20 61 6e 64 20 6e 6f 6e 65 20 72 75 6e wed and none run
b070: 6e 69 6e 67 20 74 68 65 6e 20 66 6f 72 63 65 20 ning then force
b080: 65 78 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 exit.;;.(define
b090: 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 2a *max-tries-hash*
b0a0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
b0b0: 65 29 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 e))..;; test-rec
b0c0: 6f 72 64 73 20 69 73 20 61 20 68 61 73 68 20 74 ords is a hash t
b0d0: 61 62 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 able testname:it
b0e0: 65 6d 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f em_path => vecto
b0f0: 72 20 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 r < testname tes
b100: 74 63 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 tconfig waitons
b110: 70 72 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 priority items-i
b120: 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e nfo ... >.(defin
b130: 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 e (runs:run-test
b140: 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 s-queue run-id r
b150: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
b160: 72 64 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 67 rds keyvals flag
b170: 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 71 s test-patts req
b180: 75 69 72 65 64 2d 74 65 73 74 73 20 72 65 67 6c uired-tests regl
b190: 65 6e 2d 69 6e 20 61 6c 6c 2d 74 65 73 74 73 2d en-in all-tests-
b1a0: 72 65 67 69 73 74 72 79 29 0a 20 20 3b 3b 20 41 registry). ;; A
b1b0: 74 20 74 68 69 73 20 70 6f 69 6e 74 20 74 68 65 t this point the
b1c0: 20 6c 69 73 74 20 6f 66 20 70 61 72 65 6e 74 20 list of parent
b1d0: 74 65 73 74 73 20 69 73 20 65 78 70 61 6e 64 65 tests is expande
b1e0: 64 20 0a 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f d . ;; NB// Sho
b1f0: 75 6c 64 20 65 78 70 61 6e 64 20 69 74 65 6d 73 uld expand items
b200: 20 68 65 72 65 20 61 6e 64 20 74 68 65 6e 20 69 here and then i
b210: 6e 73 65 72 74 20 69 6e 74 6f 20 74 68 65 20 72 nsert into the r
b220: 75 6e 20 71 75 65 75 65 2e 0a 20 20 28 64 65 62 un queue.. (deb
b230: 75 67 3a 70 72 69 6e 74 20 35 20 22 74 65 73 74 ug:print 5 "test
b240: 2d 72 65 63 6f 72 64 73 3a 20 22 20 74 65 73 74 -records: " test
b250: 2d 72 65 63 6f 72 64 73 20 22 2c 20 66 6c 61 67 -records ", flag
b260: 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 s: " (hash-table
b270: 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 29 0a ->alist flags)).
b280: 0a 20 20 3b 3b 20 44 6f 20 6d 61 72 6b 2d 61 6e . ;; Do mark-an
b290: 64 2d 66 69 6e 64 20 63 6c 65 61 6e 20 75 70 20 d-find clean up
b2a0: 6f 66 20 64 62 20 62 65 66 6f 72 65 20 73 74 61 of db before sta
b2b0: 72 74 69 6e 67 20 72 75 6e 69 6e 67 20 6f 66 20 rting runing of
b2c0: 71 75 75 65 0a 20 20 3b 3b 0a 20 20 3b 3b 20 28 quue. ;;. ;; (
b2d0: 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 rmt:find-and-mar
b2e0: 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 29 0a 0a 20 k-incomplete)..
b2f0: 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 6e 66 6f (let ((run-info
b300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
b310: 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 mt:get-run-info
b320: 72 75 6e 2d 69 64 29 29 0a 09 28 74 65 73 74 73 run-id))..(tests
b330: 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 20 20 -info
b340: 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (mt:get-tests-f
b350: 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 23 66 or-run run-id #f
b360: 20 27 28 29 20 27 28 29 29 29 20 3b 3b 20 20 71 '() '())) ;; q
b370: 72 79 76 61 6c 73 3a 20 22 69 64 2c 74 65 73 74 ryvals: "id,test
b380: 6e 61 6d 65 2c 69 74 65 6d 5f 70 61 74 68 22 29 name,item_path")
b390: 29 0a 09 28 73 6f 72 74 65 64 2d 74 65 73 74 2d )..(sorted-test-
b3a0: 6e 61 6d 65 73 20 20 20 20 20 28 74 65 73 74 73 names (tests
b3b0: 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 :sort-by-priorit
b3c0: 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 y-and-waiton tes
b3d0: 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 74 65 t-records))..(te
b3e0: 73 74 2d 72 65 67 69 73 74 72 79 20 20 20 20 20 st-registry
b3f0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
b400: 61 62 6c 65 29 29 0a 09 28 72 65 67 69 73 74 72 able))..(registr
b410: 79 2d 6d 75 74 65 78 20 20 20 20 20 20 20 20 28 y-mutex (
b420: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 28 6e make-mutex))..(n
b430: 75 6d 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 um-retries
b440: 20 20 20 20 20 30 29 0a 09 28 6d 61 78 2d 72 65 0)..(max-re
b450: 74 72 69 65 73 20 20 20 20 20 20 20 20 20 20 20 tries
b460: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a (config-lookup *
b470: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
b480: 70 22 20 22 6d 61 78 72 65 74 72 69 65 73 22 29 p" "maxretries")
b490: 29 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 )..(max-concurre
b4a0: 6e 74 2d 6a 6f 62 73 20 20 20 28 6c 65 74 20 28 nt-jobs (let (
b4b0: 28 6d 63 6a 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (mcj (config-loo
b4c0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
b4d0: 22 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 "setup" "max
b4e0: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
b4f0: 22 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 61 ")))..... (if (a
b500: 6e 64 20 6d 63 6a 20 28 73 74 72 69 6e 67 2d 3e nd mcj (string->
b510: 6e 75 6d 62 65 72 20 6d 63 6a 29 29 0a 09 09 09 number mcj))....
b520: 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e . (string->n
b530: 75 6d 62 65 72 20 6d 63 6a 29 0a 09 09 09 09 20 umber mcj).....
b540: 20 20 20 20 31 29 29 29 20 3b 3b 20 6c 65 6e 67 1))) ;; leng
b550: 74 68 20 6f 66 20 74 68 65 20 72 65 67 69 73 74 th of the regist
b560: 65 72 20 71 75 65 75 65 20 61 68 65 61 64 0a 09 er queue ahead..
b570: 28 72 65 67 6c 65 6e 20 20 20 20 20 20 20 20 20 (reglen
b580: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 (if (numb
b590: 65 72 3f 20 72 65 67 6c 65 6e 2d 69 6e 29 20 72 er? reglen-in) r
b5a0: 65 67 6c 65 6e 2d 69 6e 20 31 29 29 0a 09 28 6c eglen-in 1))..(l
b5b0: 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c ast-time-incompl
b5c0: 65 74 65 20 20 28 2d 20 28 63 75 72 72 65 6e 74 ete (- (current
b5d0: 2d 73 65 63 6f 6e 64 73 29 20 39 30 30 29 29 20 -seconds) 900))
b5e0: 3b 3b 20 66 6f 72 63 65 20 61 74 20 6c 65 61 73 ;; force at leas
b5f0: 74 20 6f 6e 65 20 63 6c 65 61 6e 20 75 70 20 63 t one clean up c
b600: 79 63 6c 65 0a 09 28 6c 61 73 74 2d 74 69 6d 65 ycle..(last-time
b610: 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 63 -some-running (c
b620: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
b630: 0a 09 28 74 64 62 64 61 74 20 20 20 20 20 20 20 ..(tdbdat
b640: 20 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a (tasks:
b650: 6f 70 65 6e 2d 64 62 29 29 29 0a 0a 20 20 20 20 open-db)))..
b660: 3b 3b 20 49 6e 69 74 69 61 6c 69 7a 65 20 74 68 ;; Initialize th
b670: 65 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 e test-registery
b680: 20 68 61 73 68 20 77 69 74 68 20 74 65 73 74 73 hash with tests
b690: 20 74 68 61 74 20 61 6c 72 65 61 64 79 20 68 61 that already ha
b6a0: 76 65 20 61 20 72 65 63 6f 72 64 0a 20 20 20 20 ve a record.
b6b0: 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 61 74 65 ;; convert state
b6c0: 20 74 6f 20 73 79 6d 62 6f 6c 20 61 6e 64 20 75 to symbol and u
b6d0: 73 65 20 74 68 61 74 20 61 73 20 74 68 65 20 68 se that as the h
b6e0: 61 73 68 20 76 61 6c 75 65 0a 20 20 20 20 28 66 ash value. (f
b6f0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
b700: 28 74 72 65 63 29 0a 09 09 28 6c 65 74 20 28 28 (trec)...(let ((
b710: 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d id (db:test-get-
b720: 69 64 20 20 20 20 20 20 20 20 74 72 65 63 29 29 id trec))
b730: 0a 09 09 20 20 20 20 20 20 28 74 6e 20 28 64 62 ... (tn (db
b740: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
b750: 6d 65 20 20 74 72 65 63 29 29 0a 09 09 20 20 20 me trec))...
b760: 20 20 20 28 69 70 20 28 64 62 3a 74 65 73 74 2d (ip (db:test-
b770: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 72 get-item-path tr
b780: 65 63 29 29 0a 09 09 20 20 20 20 20 20 28 73 74 ec))... (st
b790: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
b7a0: 61 74 65 20 20 20 20 20 74 72 65 63 29 29 29 0a ate trec))).
b7b0: 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 .. (if (not (eq
b7c0: 75 61 6c 3f 20 73 74 20 22 44 45 4c 45 54 45 44 ual? st "DELETED
b7d0: 22 29 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 "))... (has
b7e0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
b7f0: 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 t-registry (db:t
b800: 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 est-make-full-na
b810: 6d 65 20 74 6e 20 69 70 29 20 28 73 74 72 69 6e me tn ip) (strin
b820: 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 29 29 29 29 g->symbol st))))
b830: 29 0a 09 20 20 20 20 20 20 74 65 73 74 73 2d 69 ).. tests-i
b840: 6e 66 6f 29 0a 20 20 20 20 28 73 65 74 21 20 6d nfo). (set! m
b850: 61 78 2d 72 65 74 72 69 65 73 20 28 69 66 20 28 ax-retries (if (
b860: 61 6e 64 20 6d 61 78 2d 72 65 74 72 69 65 73 20 and max-retries
b870: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
b880: 6d 61 78 2d 72 65 74 72 69 65 73 29 29 28 73 74 max-retries))(st
b890: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 ring->number max
b8a0: 2d 72 65 74 72 69 65 73 29 20 31 30 30 29 29 0a -retries) 100)).
b8b0: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
b8c0: 28 68 65 64 20 20 20 20 20 20 20 20 20 28 63 61 (hed (ca
b8d0: 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 r sorted-test-na
b8e0: 6d 65 73 29 29 0a 09 20 20 20 20 20 20 20 28 74 mes)).. (t
b8f0: 61 6c 20 20 20 20 20 20 20 20 20 28 63 64 72 20 al (cdr
b900: 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 sorted-test-name
b910: 73 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 67 s)).. (reg
b920: 20 20 20 20 20 20 20 20 20 27 28 29 29 20 3b 3b '()) ;;
b930: 20 72 65 67 69 73 74 65 72 65 64 2c 20 70 75 74 registered, put
b940: 20 74 68 65 73 65 20 61 74 20 74 68 65 20 68 65 these at the he
b950: 61 64 20 6f 66 20 74 61 6c 20 0a 09 20 20 20 20 ad of tal ..
b960: 20 20 20 28 72 65 72 75 6e 73 20 20 20 20 20 20 (reruns
b970: 27 28 29 29 29 0a 0a 20 20 20 20 20 20 28 69 66 '())).. (if
b980: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 (not (null? rer
b990: 75 6e 73 29 29 28 64 65 62 75 67 3a 70 72 69 6e uns))(debug:prin
b9a0: 74 2d 69 6e 66 6f 20 34 20 22 72 65 72 75 6e 73 t-info 4 "reruns
b9b0: 3d 22 20 72 65 72 75 6e 73 29 29 0a 0a 20 20 20 =" reruns))..
b9c0: 20 20 20 3b 3b 20 48 65 72 65 20 77 65 20 6d 61 ;; Here we ma
b9d0: 72 6b 20 61 6e 79 20 6f 6c 64 20 64 65 66 75 6e rk any old defun
b9e0: 63 74 20 74 65 73 74 73 20 61 73 20 69 6e 63 6f ct tests as inco
b9f0: 6d 70 6c 65 74 65 2e 20 44 6f 20 74 68 69 73 20 mplete. Do this
ba00: 65 76 65 72 79 20 66 69 66 74 65 65 6e 20 6d 69 every fifteen mi
ba10: 6e 75 74 65 73 0a 20 20 20 20 20 20 3b 3b 20 6d nutes. ;; m
ba20: 6f 76 69 6e 67 20 74 68 69 73 20 74 6f 20 61 20 oving this to a
ba30: 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 20 parallel thread
ba40: 61 6e 64 20 6a 75 73 74 20 72 75 6e 20 69 74 20 and just run it
ba50: 6f 6e 63 65 2e 0a 20 20 20 20 20 20 3b 3b 0a 20 once.. ;;.
ba60: 20 20 20 20 20 28 69 66 20 28 3e 20 28 63 75 72 (if (> (cur
ba70: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 rent-seconds)(+
ba80: 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 last-time-incomp
ba90: 6c 65 74 65 20 39 30 30 29 29 0a 20 20 20 20 20 lete 900)).
baa0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
bab0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 (set! la
bac0: 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 st-time-incomple
bad0: 74 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f te (current-seco
bae0: 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 nds)).
baf0: 20 20 3b 3b 20 28 72 6d 74 3a 66 69 6e 64 2d 61 ;; (rmt:find-a
bb00: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
bb10: 74 65 2d 61 6c 6c 2d 72 75 6e 73 29 0a 09 20 20 te-all-runs)..
bb20: 20 20 29 29 0a 0a 20 20 20 20 20 20 3b 3b 20 28 )).. ;; (
bb30: 70 72 69 6e 74 20 22 54 6f 70 20 6f 66 20 6c 6f print "Top of lo
bb40: 6f 70 2c 20 68 65 64 3d 22 20 68 65 64 20 22 2c op, hed=" hed ",
bb50: 20 74 61 6c 3d 22 20 74 61 6c 20 22 20 2c 72 65 tal=" tal " ,re
bb60: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 0a 20 runs=" reruns).
bb70: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
bb80: 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 t-record (hash-t
bb90: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
bba0: 63 6f 72 64 73 20 68 65 64 29 29 0a 09 20 20 20 cords hed))..
bbb0: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 (test-name (
bbc0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
bbd0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
bbe0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
bbf0: 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 28 74 (tconfig (t
bc00: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
bc10: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 et-testconfig te
bc20: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
bc30: 20 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 28 (jobgroup (
bc40: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 config-lookup tc
bc50: 6f 6e 66 69 67 20 22 74 65 73 74 5f 6d 65 74 61 onfig "test_meta
bc60: 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 " "jobgroup"))..
bc70: 20 20 20 20 20 28 74 65 73 74 6d 6f 64 65 20 20 (testmode
bc80: 20 20 28 6c 65 74 20 28 28 6d 20 28 63 6f 6e 66 (let ((m (conf
bc90: 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 ig-lookup tconfi
bca0: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
bcb0: 20 22 6d 6f 64 65 22 29 29 29 0a 09 09 09 20 20 "mode")))....
bcc0: 20 20 28 69 66 20 6d 20 28 6d 61 70 20 73 74 72 (if m (map str
bcd0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 ing->symbol (str
bce0: 69 6e 67 2d 73 70 6c 69 74 20 6d 29 29 20 27 28 ing-split m)) '(
bcf0: 6e 6f 72 6d 61 6c 29 29 29 29 0a 09 20 20 20 20 normal))))..
bd00: 20 28 69 74 65 6d 6d 61 70 20 20 20 20 20 28 63 (itemmap (c
bd10: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 63 onfigf:lookup tc
bd20: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
bd30: 6e 74 73 22 20 22 69 74 65 6d 6d 61 70 22 29 29 nts" "itemmap"))
bd40: 0a 09 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 .. (waitons
bd50: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
bd60: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
bd70: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
bd80: 29 0a 09 20 20 20 20 20 28 70 72 69 6f 72 69 74 ).. (priorit
bd90: 79 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 y (tests:test
bda0: 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 queue-get-priori
bdb0: 74 79 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 ty test-record
bdc0: 29 29 0a 09 20 20 20 20 20 28 69 74 65 6d 64 61 )).. (itemda
bdd0: 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 t (tests:tes
bde0: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 tqueue-get-itemd
bdf0: 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 at test-recor
be00: 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 63 d)) ;; itemdat c
be10: 61 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c 20 an be a string,
be20: 6c 69 73 74 20 6f 72 20 23 66 0a 09 20 20 20 20 list or #f..
be30: 20 28 69 74 65 6d 73 20 20 20 20 20 20 20 28 74 (items (t
be40: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
be50: 65 74 2d 69 74 65 6d 73 20 20 20 20 20 20 74 65 et-items te
be60: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
be70: 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 (item-path (
be80: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path
be90: 69 74 65 6d 64 61 74 29 29 0a 09 20 20 20 20 20 itemdat))..
bea0: 28 74 66 75 6c 6c 6e 61 6d 65 20 20 20 28 64 62 (tfullname (db
beb0: 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
bec0: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
bed0: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
bee0: 20 28 6e 65 77 74 61 6c 20 20 20 20 20 20 28 61 (newtal (a
bef0: 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 20 ppend tal (list
bf00: 68 65 64 29 29 29 0a 09 20 20 20 20 20 28 72 65 hed))).. (re
bf10: 67 66 75 6c 6c 20 20 20 20 20 28 3e 3d 20 28 6c gfull (>= (l
bf20: 65 6e 67 74 68 20 72 65 67 29 20 72 65 67 6c 65 ength reg) regle
bf30: 6e 29 29 0a 09 20 20 20 20 20 28 6e 75 6d 2d 72 n)).. (num-r
bf40: 75 6e 6e 69 6e 67 20 28 72 6d 74 3a 67 65 74 2d unning (rmt:get-
bf50: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
bf60: 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 ing-for-run-id r
bf70: 75 6e 2d 69 64 29 29 29 0a 0a 09 3b 3b 20 65 76 un-id)))...;; ev
bf80: 65 72 79 20 63 6f 75 70 6c 65 20 6d 69 6e 75 74 ery couple minut
bf90: 65 73 20 76 65 72 69 66 79 20 74 68 65 20 73 65 es verify the se
bfa0: 72 76 65 72 20 69 73 20 74 68 65 72 65 20 66 6f rver is there fo
bfb0: 72 20 74 68 69 73 20 72 75 6e 0a 09 28 69 66 20 r this run..(if
bfc0: 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (and (common:low
bfd0: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 36 30 20 -noise-print 60
bfe0: 22 74 72 79 20 73 74 61 72 74 20 73 65 72 76 65 "try start serve
bff0: 72 22 20 20 72 75 6e 2d 69 64 29 0a 09 09 20 28 r" run-id)... (
c000: 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 76 65 tasks:need-serve
c010: 72 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 r run-id))..
c020: 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 (tasks:start-and
c030: 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 -wait-for-server
c040: 20 74 64 62 64 61 74 20 72 75 6e 2d 69 64 20 31 tdbdat run-id 1
c050: 30 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 64 65 6c 0)) ;; NOTE: del
c060: 61 79 20 61 6e 64 20 77 61 69 74 20 69 73 20 64 ay and wait is d
c070: 6f 6e 65 20 75 6e 64 65 72 20 74 68 65 20 68 6f one under the ho
c080: 6f 64 0a 09 0a 09 28 69 66 20 28 3e 20 6e 75 6d od....(if (> num
c090: 2d 72 75 6e 6e 69 6e 67 20 30 29 0a 09 20 20 28 -running 0).. (
c0a0: 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 2d 73 set! last-time-s
c0b0: 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 63 75 72 ome-running (cur
c0c0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
c0d0: 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 63 . (if (> (c
c0e0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
c0f0: 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 73 6f 6d 65 + last-time-some
c100: 2d 72 75 6e 6e 69 6e 67 20 28 6f 72 20 28 63 6f -running (or (co
c110: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
c120: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
c130: 20 22 67 69 76 65 2d 75 70 2d 77 61 69 74 69 6e "give-up-waitin
c140: 67 22 29 20 33 36 30 30 30 29 29 29 0a 09 20 20 g") 36000)))..
c150: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
c160: 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 *max-tries-hash
c170: 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 28 2b 20 28 * tfullname (+ (
c180: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
c190: 65 66 61 75 6c 74 20 2a 6d 61 78 2d 74 72 69 65 efault *max-trie
c1a0: 73 2d 68 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d s-hash* tfullnam
c1b0: 65 20 30 29 20 31 29 29 29 0a 09 3b 3b 20 28 64 e 0) 1)))..;; (d
c1c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 6d 61 ebug:print 0 "ma
c1d0: 78 2d 74 72 69 65 73 2d 68 61 73 68 3a 20 22 20 x-tries-hash: "
c1e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
c1f0: 73 74 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 st *max-tries-ha
c200: 73 68 2a 29 29 0a 0a 09 3b 3b 20 45 6e 73 75 72 sh*))...;; Ensur
c210: 65 20 61 6c 6c 20 74 6f 70 20 6c 65 76 65 6c 20 e all top level
c220: 74 65 73 74 73 20 67 65 74 20 72 65 67 69 73 74 tests get regist
c230: 65 72 65 64 2e 20 54 68 69 73 20 77 61 79 20 74 ered. This way t
c240: 68 65 79 20 73 68 6f 77 20 75 70 20 61 73 20 22 hey show up as "
c250: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 6f 6e 20 NOT_STARTED" on
c260: 74 68 65 20 64 61 73 68 62 6f 61 72 64 0a 09 3b the dashboard..;
c270: 3b 20 61 6e 64 20 69 74 20 69 73 20 63 6c 65 61 ; and it is clea
c280: 72 20 74 68 65 79 20 2a 73 68 6f 75 6c 64 2a 20 r they *should*
c290: 68 61 76 65 20 72 75 6e 20 62 75 74 20 64 69 64 have run but did
c2a0: 20 6e 6f 74 2e 0a 09 28 69 66 20 28 6e 6f 74 20 not...(if (not
c2b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
c2c0: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 default test-reg
c2d0: 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d istry (db:test-m
c2e0: 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 ake-full-name te
c2f0: 73 74 2d 6e 61 6d 65 20 22 22 29 20 23 66 29 29 st-name "") #f))
c300: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
c310: 20 20 20 20 28 72 6d 74 3a 72 65 67 69 73 74 65 (rmt:registe
c320: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 r-test run-id te
c330: 73 74 2d 6e 61 6d 65 20 22 22 29 0a 09 20 20 20 st-name "")..
c340: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
c350: 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
c360: 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d y (db:test-make-
c370: 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e full-name test-n
c380: 61 6d 65 20 22 22 29 20 27 64 6f 6e 65 29 29 29 ame "") 'done)))
c390: 0a 09 0a 09 3b 3b 20 46 61 73 74 20 73 6b 69 70 ....;; Fast skip
c3a0: 20 6f 66 20 74 65 73 74 73 20 74 68 61 74 20 61 of tests that a
c3b0: 72 65 20 61 6c 72 65 61 64 79 20 22 43 4f 4d 50 re already "COMP
c3c0: 4c 45 54 45 44 22 20 2d 20 4e 4f 21 20 43 61 6e LETED" - NO! Can
c3d0: 6e 6f 74 20 64 6f 20 74 68 61 74 20 61 73 20 74 not do that as t
c3e0: 68 65 20 69 74 65 6d 73 20 6d 61 79 20 6e 6f 74 he items may not
c3f0: 20 68 61 76 65 20 62 65 65 6e 20 65 78 70 61 6e have been expan
c400: 64 65 64 20 79 65 74 20 3a 28 0a 09 3b 3b 0a 09 ded yet :(..;;..
c410: 28 69 66 20 28 6d 65 6d 62 65 72 20 28 68 61 73 (if (member (has
c420: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
c430: 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 ult test-registr
c440: 79 20 74 66 75 6c 6c 6e 61 6d 65 20 23 66 29 20 y tfullname #f)
c450: 0a 09 09 20 20 20 20 27 28 44 4f 4e 4f 54 52 55 ... '(DONOTRU
c460: 4e 20 72 65 6d 6f 76 65 64 29 29 20 3b 3b 20 2a N removed)) ;; *
c470: 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d common:cant-run-
c480: 73 74 61 74 65 73 2d 73 79 6d 2a 29 20 3b 3b 20 states-sym*) ;;
c490: 27 28 43 4f 4d 50 4c 45 54 45 44 20 4b 49 4c 4c '(COMPLETED KILL
c4a0: 45 44 20 57 41 49 56 45 44 20 55 4e 4b 4e 4f 57 ED WAIVED UNKNOW
c4b0: 4e 20 49 4e 43 4f 4d 50 4c 45 54 45 29 29 0a 09 N INCOMPLETE))..
c4c0: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
c4d0: 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e (if (runs:lown
c4e0: 6f 69 73 65 20 28 63 6f 6e 63 20 22 62 65 65 6e oise (conc "been
c4f0: 20 6d 61 72 6b 65 64 20 64 6f 20 6e 6f 74 20 72 marked do not r
c500: 75 6e 20 22 20 74 66 75 6c 6c 6e 61 6d 65 29 20 un " tfullname)
c510: 36 30 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 60)... (debug:p
c520: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 rint-info 0 "Ski
c530: 70 70 69 6e 67 20 74 65 73 74 20 22 20 74 66 75 pping test " tfu
c540: 6c 6c 6e 61 6d 65 20 22 20 61 73 20 69 74 20 68 llname " as it h
c550: 61 73 20 62 65 65 6e 20 6d 61 72 6b 65 64 20 64 as been marked d
c560: 6f 20 6e 6f 74 20 72 75 6e 20 64 75 65 20 74 6f o not run due to
c570: 20 62 65 69 6e 67 20 63 6f 6d 70 6c 65 74 65 64 being completed
c580: 20 6f 72 20 6e 6f 74 20 72 75 6e 6e 61 62 6c 65 or not runnable
c590: 22 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ")).. (if (
c5a0: 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 or (not (null? t
c5b0: 61 6c 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 al))(not (null?
c5c0: 72 65 67 29 29 29 0a 09 09 20 20 28 6c 6f 6f 70 reg)))... (loop
c5d0: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
c5e0: 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t-hed tal reg re
c5f0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
c600: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
c610: 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 65 t-tal tal reg re
c620: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
c630: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
c640: 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 t-reg tal reg re
c650: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
c660: 09 72 65 72 75 6e 73 29 29 29 29 0a 09 09 20 20 .reruns))))...
c670: 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ;; (loop (car ta
c680: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 20 l)(cdr tal) reg
c690: 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 28 64 65 reruns))))...(de
c6a0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 54 4f 50 bug:print 4 "TOP
c6b0: 20 4f 46 20 4c 4f 4f 50 20 3d 3e 20 22 0a 09 09 OF LOOP => "...
c6c0: 20 20 20 20 20 22 74 65 73 74 2d 6e 61 6d 65 3a "test-name:
c6d0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 0a 09 09 20 " test-name...
c6e0: 20 20 20 20 22 5c 6e 20 20 74 65 73 74 2d 72 65 "\n test-re
c6f0: 63 6f 72 64 20 20 22 20 74 65 73 74 2d 72 65 63 cord " test-rec
c700: 6f 72 64 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 ord... "\n
c710: 68 65 64 3a 20 20 20 20 20 20 20 20 20 22 20 68 hed: " h
c720: 65 64 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 ed... "\n i
c730: 74 65 6d 64 61 74 3a 20 20 20 20 20 22 20 69 74 temdat: " it
c740: 65 6d 64 61 74 0a 09 09 20 20 20 20 20 22 5c 6e emdat... "\n
c750: 20 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 22 items: "
c760: 20 69 74 65 6d 73 0a 09 09 20 20 20 20 20 22 5c items... "\
c770: 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 20 20 n item-path:
c780: 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 20 20 " item-path...
c790: 20 20 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 3a "\n waitons:
c7a0: 20 20 20 20 20 22 20 77 61 69 74 6f 6e 73 0a 09 " waitons..
c7b0: 09 20 20 20 20 20 22 5c 6e 20 20 6e 75 6d 2d 72 . "\n num-r
c7c0: 65 74 72 69 65 73 3a 20 22 20 6e 75 6d 2d 72 65 etries: " num-re
c7d0: 74 72 69 65 73 0a 09 09 20 20 20 20 20 22 5c 6e tries... "\n
c7e0: 20 20 74 61 6c 3a 20 20 20 20 20 20 20 20 20 22 tal: "
c7f0: 20 74 61 6c 0a 09 09 20 20 20 20 20 22 5c 6e 20 tal... "\n
c800: 20 72 65 72 75 6e 73 3a 20 20 20 20 20 20 22 20 reruns: "
c810: 72 65 72 75 6e 73 0a 09 09 20 20 20 20 20 22 5c reruns... "\
c820: 6e 20 20 72 65 67 66 75 6c 6c 3a 20 20 20 20 20 n regfull:
c830: 22 20 72 65 67 66 75 6c 6c 0a 09 09 20 20 20 20 " regfull...
c840: 20 22 5c 6e 20 20 72 65 67 6c 65 6e 3a 20 20 20 "\n reglen:
c850: 20 20 20 22 20 72 65 67 6c 65 6e 0a 09 09 20 20 " reglen...
c860: 20 20 20 22 5c 6e 20 20 6c 65 6e 67 74 68 20 72 "\n length r
c870: 65 67 3a 20 20 22 20 28 6c 65 6e 67 74 68 20 72 eg: " (length r
c880: 65 67 29 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 eg)... "\n
c890: 72 65 67 3a 20 20 20 20 20 20 20 20 20 22 20 72 reg: " r
c8a0: 65 67 29 0a 0a 09 3b 3b 20 63 68 65 63 6b 20 66 eg)...;; check f
c8b0: 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e or hed in waiton
c8c0: 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 s => this would
c8d0: 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d be circular, rem
c8e0: 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 ove it and issue
c8f0: 20 61 6e 0a 09 3b 3b 20 65 72 72 6f 72 0a 09 28 an..;; error..(
c900: 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 74 2d if (member test-
c910: 6e 61 6d 65 20 77 61 69 74 6f 6e 73 29 0a 09 20 name waitons)..
c920: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
c930: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
c940: 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 74 "ERROR: test " t
c950: 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 6c est-name " has l
c960: 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 isted itself as
c970: 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 a waiton, please
c980: 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 correct this!")
c990: 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 77 61 .. (set! wa
c9a0: 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 iton (filter (la
c9b0: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
c9c0: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
c9d0: 69 74 6f 6e 73 29 29 29 29 0a 0a 09 28 63 6f 6e itons))))...(con
c9e0: 64 20 0a 09 20 0a 09 20 3b 3b 20 57 65 20 77 61 d .. .. ;; We wa
c9f0: 6e 74 20 74 6f 20 63 61 74 63 68 20 74 65 73 74 nt to catch test
ca00: 73 20 74 68 61 74 20 68 61 76 65 20 77 61 69 74 s that have wait
ca10: 6f 6e 73 20 74 68 61 74 20 61 72 65 20 4e 4f 54 ons that are NOT
ca20: 20 69 6e 20 74 68 65 20 71 75 65 75 65 20 61 6e in the queue an
ca30: 64 20 64 69 73 63 61 72 64 20 74 68 65 6d 20 49 d discard them I
ca40: 46 46 20 0a 09 20 3b 3b 20 74 68 65 79 20 68 61 FF .. ;; they ha
ca50: 76 65 20 62 65 65 6e 20 74 68 72 6f 75 67 68 20 ve been through
ca60: 74 68 65 20 77 72 69 6e 67 65 72 20 31 30 20 6f the wringer 10 o
ca70: 72 20 6d 6f 72 65 20 74 69 6d 65 73 0a 09 20 28 r more times.. (
ca80: 28 61 6e 64 20 28 6c 69 73 74 3f 20 77 61 69 74 (and (list? wait
ca90: 6f 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6e 6f ons).. (no
caa0: 74 20 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 t (null? waitons
cab0: 29 29 0a 09 20 20 20 20 20 20 20 28 3e 20 28 68 )).. (> (h
cac0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
cad0: 66 61 75 6c 74 20 2a 6d 61 78 2d 74 72 69 65 73 fault *max-tries
cae0: 2d 68 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d 65 -hash* tfullname
caf0: 20 30 29 20 31 30 29 0a 09 20 20 20 20 20 20 20 0) 10)..
cb00: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 66 69 6c (not (null? (fil
cb10: 74 65 72 0a 09 09 09 20 20 20 20 6e 75 6d 62 65 ter.... numbe
cb20: 72 3f 0a 09 09 09 20 20 20 20 28 6d 61 70 20 28 r?.... (map (
cb30: 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a lambda (waiton).
cb40: 09 09 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 .... (if (and
cb50: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 (not (member wai
cb60: 74 6f 6e 20 74 61 6c 29 29 20 20 20 20 20 20 20 ton tal))
cb70: 20 20 20 20 20 3b 3b 20 74 68 69 73 20 77 61 69 ;; this wai
cb80: 74 6f 6e 20 69 73 20 6e 6f 74 20 69 6e 20 74 68 ton is not in th
cb90: 65 20 6c 69 73 74 20 74 6f 20 62 65 20 74 72 69 e list to be tri
cba0: 65 64 20 74 6f 20 72 75 6e 0a 09 09 09 09 09 20 ed to run......
cbb0: 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 (not (member
cbc0: 77 61 69 74 6f 6e 20 72 65 72 75 6e 73 29 29 29 waiton reruns)))
cbd0: 0a 09 09 09 09 20 20 20 20 20 20 20 31 0a 09 09 ..... 1...
cbe0: 09 09 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 .. #f))...
cbf0: 09 09 20 77 61 69 74 6f 6e 73 29 29 29 29 29 20 .. waitons)))))
cc00: 3b 3b 20 63 6f 75 6c 64 20 64 6f 20 74 68 69 73 ;; could do this
cc10: 20 6d 6f 72 65 20 65 6c 65 67 61 6e 74 6c 79 20 more elegantly
cc20: 77 69 74 68 20 61 20 6d 61 72 6b 65 72 2e 2e 2e with a marker...
cc30: 2e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
cc40: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 t 0 "WARNING: Ma
cc50: 72 6b 69 6e 67 20 74 65 73 74 20 22 20 74 66 75 rking test " tfu
cc60: 6c 6c 6e 61 6d 65 20 22 20 61 73 20 6e 6f 74 20 llname " as not
cc70: 72 75 6e 6e 61 62 6c 65 2e 20 49 74 20 69 73 20 runnable. It is
cc80: 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 waiting on tests
cc90: 20 74 68 61 74 20 63 61 6e 6e 6f 74 20 62 65 20 that cannot be
cca0: 72 75 6e 2e 20 47 69 76 69 6e 67 20 75 70 20 6e run. Giving up n
ccb0: 6f 77 2e 22 29 0a 09 20 20 28 68 61 73 68 2d 74 ow.").. (hash-t
ccc0: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
ccd0: 65 67 69 73 74 72 79 20 74 66 75 6c 6c 6e 61 6d egistry tfullnam
cce0: 65 20 27 72 65 6d 6f 76 65 64 29 29 0a 0a 09 20 e 'removed))...
ccf0: 3b 3b 20 69 74 65 6d 73 20 69 73 20 23 66 20 74 ;; items is #f t
cd00: 68 65 6e 20 74 68 65 20 74 65 73 74 20 69 73 20 hen the test is
cd10: 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 65 64 20 ok to be handed
cd20: 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 20 28 62 off to launch (b
cd30: 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 29 0a 09 ut not before)..
cd40: 20 3b 3b 20 0a 09 20 28 28 6e 6f 74 20 69 74 65 ;; .. ((not ite
cd50: 6d 73 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 ms).. (debug:pr
cd60: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 4f 55 54 45 int-info 4 "OUTE
cd70: 52 20 43 4f 4e 44 3a 20 28 6e 6f 74 20 69 74 65 R COND: (not ite
cd80: 6d 73 29 22 29 0a 09 20 20 28 69 66 20 28 61 6e ms)").. (if (an
cd90: 64 20 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 d (not (tests:ma
cda0: 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 28 tch test-patts (
cdb0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
cdc0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
cdd0: 74 2d 72 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 t-record) item-p
cde0: 61 74 68 20 72 65 71 75 69 72 65 64 3a 20 72 65 ath required: re
cdf0: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
ce00: 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 . (not (null?
ce10: 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 6c tal))).. (l
ce20: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
ce30: 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e r tal) reg rerun
ce40: 73 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6c 6f s)).. (let ((lo
ce50: 6f 70 2d 6c 69 73 74 20 28 72 75 6e 73 3a 70 72 op-list (runs:pr
ce60: 6f 63 65 73 73 2d 65 78 70 61 6e 64 65 64 2d 74 ocess-expanded-t
ce70: 65 73 74 73 20 68 65 64 20 74 61 6c 20 72 65 67 ests hed tal reg
ce80: 20 72 65 72 75 6e 73 20 72 65 67 6c 65 6e 20 72 reruns reglen r
ce90: 65 67 66 75 6c 6c 20 74 65 73 74 2d 72 65 63 6f egfull test-reco
cea0: 72 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d rd runname test-
ceb0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 6a name item-path j
cec0: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
ced0: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d urrent-jobs run-
cee0: 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d id waitons item-
cef0: 70 61 74 68 20 74 65 73 74 6d 6f 64 65 20 74 65 path testmode te
cf00: 73 74 2d 70 61 74 74 73 20 72 65 71 75 69 72 65 st-patts require
cf10: 64 2d 74 65 73 74 73 20 74 65 73 74 2d 72 65 67 d-tests test-reg
cf20: 69 73 74 72 79 20 72 65 67 69 73 74 72 79 2d 6d istry registry-m
cf30: 75 74 65 78 20 66 6c 61 67 73 20 6b 65 79 76 61 utex flags keyva
cf40: 6c 73 20 72 75 6e 2d 69 6e 66 6f 20 6e 65 77 74 ls run-info newt
cf50: 61 6c 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 al all-tests-reg
cf60: 69 73 74 72 79 20 69 74 65 6d 6d 61 70 29 29 29 istry itemmap)))
cf70: 0a 09 20 20 20 20 28 69 66 20 6c 6f 6f 70 2d 6c .. (if loop-l
cf80: 69 73 74 20 28 61 70 70 6c 79 20 6c 6f 6f 70 20 ist (apply loop
cf90: 6c 6f 6f 70 2d 6c 69 73 74 29 29 29 29 0a 0a 09 loop-list))))...
cfa0: 20 3b 3b 20 69 74 65 6d 73 20 70 72 6f 63 65 73 ;; items proces
cfb0: 73 65 64 20 69 6e 74 6f 20 61 20 6c 69 73 74 20 sed into a list
cfc0: 62 75 74 20 6e 6f 74 20 63 61 6d 65 20 69 6e 20 but not came in
cfd0: 61 73 20 61 20 6c 69 73 74 20 62 65 65 6e 20 70 as a list been p
cfe0: 72 6f 63 65 73 73 65 64 0a 09 20 3b 3b 0a 09 20 rocessed.. ;;..
cff0: 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 ((and (list? ite
d000: 6d 73 29 20 20 20 20 20 3b 3b 20 74 68 75 73 20 ms) ;; thus
d010: 77 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 65 6d we know our item
d020: 73 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 61 s are already ca
d030: 6c 63 75 6c 61 74 65 64 0a 09 20 20 20 20 20 20 lculated..
d040: 20 28 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 29 (not itemdat)
d050: 29 20 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 ) ;; and not ye
d060: 74 20 65 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 t expanded into
d070: 74 68 65 20 6c 69 73 74 20 6f 66 20 74 68 69 6e the list of thin
d080: 67 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 gs to be done..
d090: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
d0a0: 66 6f 20 34 20 22 4f 55 54 45 52 20 43 4f 4e 44 fo 4 "OUTER COND
d0b0: 3a 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 : (and (list? it
d0c0: 65 6d 73 29 28 6e 6f 74 20 69 74 65 6d 64 61 74 ems)(not itemdat
d0d0: 29 29 22 29 0a 09 20 20 3b 3b 20 4d 75 73 74 20 ))").. ;; Must
d0e0: 64 65 74 65 72 6d 69 6e 65 20 69 66 20 74 68 65 determine if the
d0f0: 20 69 74 65 6d 73 20 6c 69 73 74 20 69 73 20 76 items list is v
d100: 61 6c 69 64 2e 20 44 69 73 63 61 72 64 20 74 68 alid. Discard th
d110: 65 20 74 65 73 74 20 69 66 20 69 74 20 69 73 20 e test if it is
d120: 6e 6f 74 2e 0a 09 20 20 28 69 66 20 28 61 6e 64 not... (if (and
d130: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 0a 09 (list? items)..
d140: 09 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 69 . (> (length i
d150: 74 65 6d 73 29 20 30 29 0a 09 09 20 20 20 28 61 tems) 0)... (a
d160: 6e 64 20 28 6c 69 73 74 3f 20 28 63 61 72 20 69 nd (list? (car i
d170: 74 65 6d 73 29 29 0a 09 09 09 28 3e 20 28 6c 65 tems))....(> (le
d180: 6e 67 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 ngth (car items)
d190: 29 20 30 29 29 0a 09 09 20 20 20 28 64 65 62 75 ) 0))... (debu
d1a0: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 g:debug-mode 1))
d1b0: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
d1c0: 72 69 6e 74 20 32 20 28 6d 61 70 20 28 6c 61 6d rint 2 (map (lam
d1d0: 62 64 61 20 28 72 6f 77 29 0a 09 09 09 09 20 20 bda (row).....
d1e0: 20 20 28 63 6f 6e 63 20 28 73 74 72 69 6e 67 2d (conc (string-
d1f0: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 09 intersperse.....
d200: 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 . (map (lambda
d210: 20 28 76 61 72 76 61 6c 29 0a 09 09 09 09 09 09 (varval).......
d220: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
d230: 70 65 72 73 65 20 76 61 72 76 61 6c 20 22 3d 22 perse varval "="
d240: 29 29 0a 09 09 09 09 09 09 72 6f 77 29 0a 09 09 )).......row)...
d250: 09 09 09 20 20 20 22 20 22 29 0a 09 09 09 09 09 ... " ")......
d260: 20 20 22 5c 6e 22 29 29 0a 09 09 09 09 20 20 69 "\n"))..... i
d270: 74 65 6d 73 29 29 29 0a 09 20 20 28 66 6f 72 2d tems))).. (for-
d280: 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 each.. (lambda
d290: 20 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 20 (my-itemdat)..
d2a0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d (let* ((new-
d2b0: 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 test-record (let
d2c0: 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d ((newrec (make-
d2d0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 29 tests:testqueue)
d2e0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 ))..... (v
d2f0: 65 63 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 ector-copy! test
d300: 2d 72 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a -record newrec).
d310: 09 09 09 09 20 20 20 20 20 20 20 6e 65 77 72 65 .... newre
d320: 63 29 29 0a 09 09 20 20 20 20 28 6d 79 2d 69 74 c))... (my-it
d330: 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 em-path (item-li
d340: 73 74 2d 3e 70 61 74 68 20 6d 79 2d 69 74 65 6d st->path my-item
d350: 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 20 28 dat))).. (
d360: 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 if (tests:match
d370: 74 65 73 74 2d 70 61 74 74 73 20 68 65 64 20 6d test-patts hed m
d380: 79 2d 69 74 65 6d 2d 70 61 74 68 20 72 65 71 75 y-item-path requ
d390: 69 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d 74 ired: required-t
d3a0: 65 73 74 73 29 20 3b 3b 20 28 70 61 74 74 2d 6c ests) ;; (patt-l
d3b0: 69 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 74 65 ist-match my-ite
d3c0: 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 74 m-path item-patt
d3d0: 73 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 s) ;;
d3e0: 79 65 73 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 yes, we want to
d3f0: 70 72 6f 63 65 73 73 20 74 68 69 73 20 69 74 65 process this ite
d400: 6d 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 m, NOTE: Should
d410: 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 20 63 68 not need this ch
d420: 65 63 6b 20 68 65 72 65 21 0a 09 09 20 20 20 28 eck here!... (
d430: 6c 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d let ((newtestnam
d440: 65 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d e (db:test-make-
d450: 66 75 6c 6c 2d 6e 61 6d 65 20 68 65 64 20 6d 79 full-name hed my
d460: 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 20 20 -item-path)))
d470: 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 61 ;; test names a
d480: 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 73 re unique on tes
d490: 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 0a tname/item-path.
d4a0: 09 09 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 .. (tests:te
d4b0: 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d stqueue-set-item
d4c0: 73 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d s! new-test-
d4d0: 72 65 63 6f 72 64 20 23 66 29 0a 09 09 20 20 20 record #f)...
d4e0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
d4f0: 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 20 ue-set-itemdat!
d500: 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 new-test-recor
d510: 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 d my-itemdat)...
d520: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
d530: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 queue-set-item_p
d540: 61 74 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 ath! new-test-re
d550: 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 cord my-item-pat
d560: 68 29 0a 09 09 20 20 20 20 20 28 68 61 73 68 2d h)... (hash-
d570: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
d580: 72 65 63 6f 72 64 73 20 6e 65 77 74 65 73 74 6e records newtestn
d590: 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 ame new-test-rec
d5a0: 6f 72 64 29 0a 09 09 20 20 20 20 20 28 73 65 74 ord)... (set
d5b0: 21 20 74 61 6c 20 28 61 70 70 65 6e 64 20 74 61 ! tal (append ta
d5c0: 6c 20 28 6c 69 73 74 20 6e 65 77 74 65 73 74 6e l (list newtestn
d5d0: 61 6d 65 29 29 29 29 29 29 29 20 3b 3b 20 73 69 ame))))))) ;; si
d5e0: 6e 63 65 20 74 68 65 73 65 20 61 72 65 20 69 74 nce these are it
d5f0: 65 6d 69 7a 65 64 20 63 72 65 61 74 65 20 6e 65 emized create ne
d600: 77 20 74 65 73 74 20 6e 61 6d 65 73 20 74 65 73 w test names tes
d610: 74 6e 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 tname/itempath..
d620: 20 20 20 69 74 65 6d 73 29 0a 0a 09 20 20 3b 3b items)... ;;
d630: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
d640: 66 6f 20 30 20 22 54 65 73 74 20 22 20 28 74 65 fo 0 "Test " (te
d650: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
d660: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
d670: 72 65 63 6f 72 64 29 20 22 20 69 73 20 69 74 65 record) " is ite
d680: 6d 69 7a 65 64 20 62 75 74 20 68 61 73 20 6e 6f mized but has no
d690: 20 69 74 65 6d 73 22 29 0a 0a 09 20 20 3b 3b 20 items")... ;;
d6a0: 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 77 65 At this point we
d6b0: 20 68 61 76 65 20 70 6f 73 73 69 62 6c 79 20 61 have possibly a
d6c0: 64 64 65 64 20 69 74 65 6d 73 20 74 6f 20 74 61 dded items to ta
d6d0: 6c 20 62 75 74 20 61 6c 6c 20 6d 75 73 74 20 62 l but all must b
d6e0: 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 e handed off to
d6f0: 0a 09 20 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e .. ;; INNER CON
d700: 44 20 6c 6f 67 69 63 2e 20 49 20 74 68 69 6e 6b D logic. I think
d710: 20 6c 6f 6f 70 20 77 69 74 68 6f 75 74 20 72 6f loop without ro
d720: 74 61 74 69 6e 67 20 74 68 65 20 71 75 65 75 65 tating the queue
d730: 20 0a 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 68 65 .. ;; (loop he
d740: 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 d tal reg reruns
d750: 29 29 0a 09 20 20 3b 3b 20 28 6c 65 74 20 28 28 )).. ;; (let ((
d760: 6e 65 77 74 61 6c 20 28 61 70 70 65 6e 64 20 74 newtal (append t
d770: 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 al (list hed))))
d780: 20 20 3b 3b 20 57 65 20 73 68 6f 75 6c 64 20 64 ;; We should d
d790: 69 73 63 61 72 64 20 68 65 64 20 61 73 20 69 74 iscard hed as it
d7a0: 20 68 61 73 20 62 65 65 6e 20 65 78 70 61 6e 64 has been expand
d7b0: 65 64 20 69 6e 74 6f 20 69 74 27 73 20 69 74 65 ed into it's ite
d7c0: 6d 73 3f 20 59 65 73 2c 20 62 75 74 20 6f 6e 6c ms? Yes, but onl
d7d0: 79 20 69 66 20 74 68 69 73 20 2a 69 73 2a 20 61 y if this *is* a
d7e0: 6e 20 69 74 65 6d 69 7a 65 64 20 74 65 73 74 0a n itemized test.
d7f0: 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 72 . ;; (loop (car
d800: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
d810: 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 tal) reg reruns)
d820: 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 .. (if (null? t
d830: 61 6c 29 0a 09 20 20 20 20 20 20 23 66 0a 09 20 al).. #f..
d840: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
d850: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
d860: 67 20 72 65 72 75 6e 73 29 29 29 0a 09 20 20 20 g reruns)))..
d870: 20 0a 09 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 .. ;; if items
d880: 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e is a proc then n
d890: 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 eed to run items
d8a0: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
d8b0: 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 config, get the
d8c0: 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 list and loop ..
d8d0: 20 3b 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e 6c ;; - but onl
d8e0: 79 20 64 6f 20 74 68 61 74 20 69 66 20 72 65 73 y do that if res
d8f0: 6f 75 72 63 65 73 20 65 78 69 73 74 20 74 6f 20 ources exist to
d900: 6b 69 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f 62 kick off the job
d910: 0a 09 20 3b 3b 20 45 58 50 41 4e 44 20 49 54 45 .. ;; EXPAND ITE
d920: 4d 53 0a 09 20 28 28 6f 72 20 28 70 72 6f 63 65 MS.. ((or (proce
d930: 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 3f dure? items)(eq?
d940: 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 6f items 'have-pro
d950: 63 65 64 75 72 65 29 29 0a 09 20 20 28 6c 65 74 cedure)).. (let
d960: 20 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 ((can-run-more
d970: 20 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e (runs:can-run
d980: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 75 6e 2d -more-tests run-
d990: 69 64 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d id jobgroup max-
d9a0: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 concurrent-jobs)
d9b0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 )).. (if (and
d9c0: 20 28 6c 69 73 74 3f 20 63 61 6e 2d 72 75 6e 2d (list? can-run-
d9d0: 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 28 63 61 more)... (ca
d9e0: 72 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 29 r can-run-more))
d9f0: 0a 09 09 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c ...(let ((loop-l
da00: 69 73 74 20 28 72 75 6e 73 3a 65 78 70 61 6e 64 ist (runs:expand
da10: 2d 69 74 65 6d 73 20 68 65 64 20 74 61 6c 20 72 -items hed tal r
da20: 65 67 20 72 65 72 75 6e 73 20 72 65 67 66 75 6c eg reruns regful
da30: 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 67 72 6f 75 l newtal jobgrou
da40: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
da50: 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 -jobs run-id wai
da60: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 tons item-path t
da70: 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 72 65 63 estmode test-rec
da80: 6f 72 64 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ord can-run-more
da90: 20 69 74 65 6d 73 20 72 75 6e 6e 61 6d 65 20 74 items runname t
daa0: 63 6f 6e 66 69 67 20 72 65 67 6c 65 6e 20 74 65 config reglen te
dab0: 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 st-registry test
dac0: 2d 72 65 63 6f 72 64 73 20 69 74 65 6d 6d 61 70 -records itemmap
dad0: 29 29 29 0a 09 09 20 20 28 69 66 20 6c 6f 6f 70 )))... (if loop
dae0: 2d 6c 69 73 74 0a 09 09 20 20 20 20 20 20 28 61 -list... (a
daf0: 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c pply loop loop-l
db00: 69 73 74 29 29 29 0a 09 09 3b 3b 20 69 66 20 63 ist)))...;; if c
db10: 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 an't run more ju
db20: 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 st loop with nex
db30: 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a t possible test.
db40: 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 ..(loop (car new
db50: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
db60: 20 72 65 67 20 72 65 72 75 6e 73 29 29 29 29 0a reg reruns)))).
db70: 09 20 20 20 20 0a 09 20 3b 3b 20 74 68 69 73 20 . .. ;; this
db80: 63 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 case should not
db90: 68 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f happen, added to
dba0: 20 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 help catch any
dbb0: 62 75 67 73 0a 09 20 28 28 61 6e 64 20 28 6c 69 bugs.. ((and (li
dbc0: 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 64 st? items) itemd
dbd0: 61 74 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 at).. (debug:pr
dbe0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 53 68 int 0 "ERROR: Sh
dbf0: 6f 75 6c 64 20 6e 6f 74 20 68 61 76 65 20 61 20 ould not have a
dc00: 6c 69 73 74 20 6f 66 20 69 74 65 6d 73 20 69 6e list of items in
dc10: 20 61 20 74 65 73 74 20 61 6e 64 20 74 68 65 20 a test and the
dc20: 69 74 65 6d 73 70 61 74 68 20 73 65 74 20 2d 20 itemspath set -
dc30: 70 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 please report th
dc40: 69 73 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 is").. (exit 1)
dc50: 29 0a 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ).. ((not (null?
dc60: 20 72 65 72 75 6e 73 29 29 0a 09 20 20 28 6c 65 reruns)).. (le
dc70: 74 2a 20 28 28 6e 65 77 6c 73 74 20 28 74 65 73 t* ((newlst (tes
dc80: 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 ts:filter-non-ru
dc90: 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 20 74 61 nnable run-id ta
dca0: 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 l test-records))
dcb0: 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 20 46 41 49 ;; i.e. not FAI
dcc0: 4c 2c 20 57 41 49 56 45 44 2c 20 49 4e 43 4f 4d L, WAIVED, INCOM
dcd0: 50 4c 45 54 45 2c 20 50 41 53 53 2c 20 4b 49 4c PLETE, PASS, KIL
dce0: 4c 45 44 2c 0a 09 09 20 28 6a 75 6e 6b 65 64 20 LED,... (junked
dcf0: 28 6c 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 (lset-difference
dd00: 20 65 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c equal? tal newl
dd10: 73 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 st))).. (debu
dd20: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
dd30: 66 75 6c 6c 20 64 72 6f 70 20 74 68 72 6f 75 67 full drop throug
dd40: 68 2c 20 69 66 20 72 65 72 75 6e 73 20 69 73 20 h, if reruns is
dd50: 6c 65 73 73 20 74 68 61 6e 20 31 30 30 20 77 65 less than 100 we
dd60: 20 77 69 6c 6c 20 66 6f 72 63 65 20 72 65 74 72 will force retr
dd70: 79 20 74 68 65 6d 2c 20 72 65 72 75 6e 73 3d 22 y them, reruns="
dd80: 20 72 65 72 75 6e 73 20 22 2c 20 74 61 6c 3d 22 reruns ", tal="
dd90: 20 74 61 6c 29 0a 09 20 20 20 20 28 69 66 20 28 tal).. (if (
dda0: 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 6d 61 < num-retries ma
ddb0: 78 2d 72 65 74 72 69 65 73 29 0a 09 09 28 73 65 x-retries)...(se
ddc0: 74 21 20 6e 65 77 6c 73 74 20 28 61 70 70 65 6e t! newlst (appen
ddd0: 64 20 72 65 72 75 6e 73 20 6e 65 77 6c 73 74 29 d reruns newlst)
dde0: 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 6e 75 )).. (set! nu
ddf0: 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 6e 75 6d m-retries (+ num
de00: 2d 72 65 74 72 69 65 73 20 31 29 29 0a 09 20 20 -retries 1))..
de10: 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 ;; (thread-sle
de20: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
de30: 2d 64 65 6c 74 61 2a 29 29 0a 09 20 20 20 20 28 -delta*)).. (
de40: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e if (not (null? n
de50: 65 77 6c 73 74 29 29 0a 09 09 3b 3b 20 73 69 6e ewlst))...;; sin
de60: 63 65 20 72 65 72 75 6e 73 20 68 61 76 65 20 62 ce reruns have b
de70: 65 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 6f een tacked on to
de80: 20 6e 65 77 6c 73 74 20 63 72 65 61 74 65 20 6e newlst create n
de90: 65 77 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 6a ew reruns from j
dea0: 75 6e 6b 65 64 0a 09 09 28 6c 6f 6f 70 20 28 63 unked...(loop (c
deb0: 61 72 20 6e 65 77 6c 73 74 29 28 63 64 72 20 6e ar newlst)(cdr n
dec0: 65 77 6c 73 74 29 20 72 65 67 20 28 64 65 6c 65 ewlst) reg (dele
ded0: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 te-duplicates ju
dee0: 6e 6b 65 64 29 29 29 29 29 0a 09 20 28 28 6e 6f nked))))).. ((no
def0: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
df00: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
df10: 6e 66 6f 20 34 20 22 49 27 6d 20 70 72 65 74 74 nfo 4 "I'm prett
df20: 79 20 73 75 72 65 20 49 20 73 68 6f 75 6c 64 6e y sure I shouldn
df30: 27 74 20 67 65 74 20 68 65 72 65 2e 22 29 29 0a 't get here.")).
df40: 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 . ((not (null? r
df50: 65 67 29 29 20 3b 3b 20 63 6f 75 6c 64 20 77 65 eg)) ;; could we
df60: 20 67 65 74 20 68 65 72 65 20 77 69 74 68 20 6c get here with l
df70: 65 66 74 6f 76 65 72 73 3f 0a 09 20 20 28 64 65 eftovers?.. (de
df80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
df90: 20 22 48 61 76 65 20 6c 65 66 74 6f 76 65 72 73 "Have leftovers
dfa0: 21 22 29 0a 09 20 20 28 6c 6f 6f 70 20 28 63 61 !").. (loop (ca
dfb0: 72 20 72 65 67 29 28 63 64 72 20 72 65 67 29 20 r reg)(cdr reg)
dfc0: 27 28 29 20 72 65 72 75 6e 73 29 29 0a 09 20 28 '() reruns)).. (
dfd0: 65 6c 73 65 0a 09 20 20 28 64 65 62 75 67 3a 70 else.. (debug:p
dfe0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 78 69 rint-info 4 "Exi
dff0: 74 69 6e 67 20 6c 6f 6f 70 20 77 69 74 68 2e 2e ting loop with..
e000: 2e 5c 6e 20 20 68 65 64 3d 22 20 68 65 64 20 22 .\n hed=" hed "
e010: 5c 6e 20 20 74 61 6c 3d 22 20 74 61 6c 20 22 5c \n tal=" tal "\
e020: 6e 20 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 n reruns=" reru
e030: 6e 73 29 29 0a 09 20 29 29 29 0a 20 20 20 20 3b ns)).. ))). ;
e040: 3b 20 6e 6f 77 20 2a 69 66 2a 20 2d 72 75 6e 2d ; now *if* -run-
e050: 77 61 69 74 20 77 65 20 77 61 69 74 20 66 6f 72 wait we wait for
e060: 20 61 6c 6c 20 74 65 73 74 73 20 74 6f 20 62 65 all tests to be
e070: 20 64 6f 6e 65 0a 20 20 20 20 3b 3b 20 4e 6f 77 done. ;; Now
e080: 20 77 61 69 74 20 66 6f 72 20 61 6e 79 20 52 55 wait for any RU
e090: 4e 4e 49 4e 47 20 74 65 73 74 73 20 74 6f 20 63 NNING tests to c
e0a0: 6f 6d 70 6c 65 74 65 20 28 69 66 20 69 6e 20 72 omplete (if in r
e0b0: 75 6e 2d 77 61 69 74 20 6d 6f 64 65 29 0a 20 20 un-wait mode).
e0c0: 20 20 28 6c 65 74 20 77 61 69 74 2d 6c 6f 6f 70 (let wait-loop
e0d0: 20 28 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 ((num-running
e0e0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 (rmt:get-cou
e0f0: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
e100: 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d -for-run-id run-
e110: 69 64 29 29 0a 09 09 20 20 20 20 28 70 72 65 76 id))... (prev
e120: 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 29 -num-running 0))
e130: 0a 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 . ;; (debug
e140: 3a 70 72 69 6e 74 20 30 20 22 6e 75 6d 2d 72 75 :print 0 "num-ru
e150: 6e 6e 69 6e 67 3d 22 20 6e 75 6d 2d 72 75 6e 6e nning=" num-runn
e160: 69 6e 67 20 22 2c 20 70 72 65 76 2d 6e 75 6d 2d ing ", prev-num-
e170: 72 75 6e 6e 69 6e 67 3d 22 20 70 72 65 76 2d 6e running=" prev-n
e180: 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 um-running).
e190: 20 20 28 69 66 20 28 61 6e 64 20 28 6f 72 20 28 (if (and (or (
e1a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
e1b0: 75 6e 2d 77 61 69 74 22 29 0a 09 09 20 20 20 28 un-wait")... (
e1c0: 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a equal? (configf:
e1d0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
e1e0: 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e 2d t* "setup" "run-
e1f0: 77 61 69 74 22 29 20 22 79 65 73 22 29 29 0a 09 wait") "yes"))..
e200: 20 20 20 20 20 20 20 28 3e 20 6e 75 6d 2d 72 75 (> num-ru
e210: 6e 6e 69 6e 67 20 30 29 29 0a 09 20 20 28 62 65 nning 0)).. (be
e220: 67 69 6e 0a 09 20 20 20 20 3b 3b 20 48 65 72 65 gin.. ;; Here
e230: 20 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f 6c 64 we mark any old
e240: 20 64 65 66 75 6e 63 74 20 74 65 73 74 73 20 61 defunct tests a
e250: 73 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 44 6f s incomplete. Do
e260: 20 74 68 69 73 20 65 76 65 72 79 20 66 69 66 74 this every fift
e270: 65 65 6e 20 6d 69 6e 75 74 65 73 0a 09 20 20 20 een minutes..
e280: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
e290: 20 30 20 22 47 6f 74 20 68 65 72 65 20 65 68 21 0 "Got here eh!
e2a0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3d 22 20 6e num-running=" n
e2b0: 75 6d 2d 72 75 6e 6e 69 6e 67 20 22 20 28 3e 20 um-running " (>
e2c0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 20 22 num-running 0) "
e2d0: 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 (> num-running
e2e0: 30 29 29 0a 09 20 20 20 20 28 69 66 20 28 3e 20 0)).. (if (>
e2f0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
e300: 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 69 6e )(+ last-time-in
e310: 63 6f 6d 70 6c 65 74 65 20 39 30 30 29 29 0a 09 complete 900))..
e320: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
e330: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
e340: 22 4d 61 72 6b 69 6e 67 20 73 74 75 63 6b 20 74 "Marking stuck t
e350: 65 73 74 73 20 61 73 20 49 4e 43 4f 4d 50 4c 45 ests as INCOMPLE
e360: 54 45 20 77 68 69 6c 65 20 77 61 69 74 69 6e 67 TE while waiting
e370: 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 2d 69 for run " run-i
e380: 64 20 22 2e 20 52 75 6e 6e 69 6e 67 20 61 73 20 d ". Running as
e390: 70 69 64 20 22 20 28 63 75 72 72 65 6e 74 2d 70 pid " (current-p
e3a0: 72 6f 63 65 73 73 2d 69 64 29 20 22 20 6f 6e 20 rocess-id) " on
e3b0: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
e3c0: 29 29 0a 09 09 20 20 28 73 65 74 21 20 6c 61 73 ))... (set! las
e3d0: 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 74 t-time-incomplet
e3e0: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
e3f0: 64 73 29 29 0a 09 09 20 20 28 72 6d 74 3a 66 69 ds))... (rmt:fi
e400: 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f nd-and-mark-inco
e410: 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 23 66 mplete run-id #f
e420: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f ))).. (if (no
e430: 74 20 28 65 71 3f 20 6e 75 6d 2d 72 75 6e 6e 69 t (eq? num-runni
e440: 6e 67 20 70 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e ng prev-num-runn
e450: 69 6e 67 29 29 0a 09 09 28 64 65 62 75 67 3a 70 ing))...(debug:p
e460: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 72 75 6e rint-info 0 "run
e470: 2d 77 61 69 74 20 73 70 65 63 69 66 69 65 64 2c -wait specified,
e480: 20 77 61 69 74 69 6e 67 20 6f 6e 20 22 20 6e 75 waiting on " nu
e490: 6d 2d 72 75 6e 6e 69 6e 67 20 22 20 74 65 73 74 m-running " test
e4a0: 73 20 69 6e 20 52 55 4e 4e 49 4e 47 2c 20 52 45 s in RUNNING, RE
e4b0: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 6f 72 MOTEHOSTSTART or
e4c0: 20 4c 41 55 4e 43 48 45 44 20 73 74 61 74 65 20 LAUNCHED state
e4d0: 61 74 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 at " (time->stri
e4e0: 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 ng (seconds->loc
e4f0: 61 6c 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 al-time (current
e500: 2d 73 65 63 6f 6e 64 73 29 29 29 29 29 0a 09 20 -seconds)))))..
e510: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
e520: 21 20 35 29 0a 09 20 20 20 20 3b 3b 20 28 77 61 ! 5).. ;; (wa
e530: 69 74 2d 6c 6f 6f 70 20 28 72 6d 74 3a 67 65 74 it-loop (rmt:get
e540: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
e550: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ning-for-run-id
e560: 72 75 6e 2d 69 64 29 20 6e 75 6d 2d 72 75 6e 6e run-id) num-runn
e570: 69 6e 67 29 29 29 29 0a 09 20 20 20 20 28 77 61 ing)))).. (wa
e580: 69 74 2d 6c 6f 6f 70 20 28 72 6d 74 3a 67 65 74 it-loop (rmt:get
e590: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
e5a0: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ning-for-run-id
e5b0: 72 75 6e 2d 69 64 29 20 6e 75 6d 2d 72 75 6e 6e run-id) num-runn
e5c0: 69 6e 67 29 29 29 29 0a 20 20 20 20 3b 3b 20 4c ing)))). ;; L
e5d0: 45 54 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 ET* ((test-recor
e5e0: 64 0a 20 20 20 20 3b 3b 20 77 65 20 67 65 74 20 d. ;; we get
e5f0: 68 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 here on "drop th
e600: 72 6f 75 67 68 22 2e 20 41 6c 6c 20 64 6f 6e 65 rough". All done
e610: 21 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 !. (debug:pri
e620: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 6c 6c 20 74 nt-info 1 "All t
e630: 65 73 74 73 20 6c 61 75 6e 63 68 65 64 22 29 29 ests launched"))
e640: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
e650: 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 :calc-fails prer
e660: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 eqs-not-met). (
e670: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
e680: 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 test).. (and
e690: 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b (vector? test) ;
e6a0: 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 ; not (string? t
e6b0: 65 73 74 29 29 0a 09 09 20 28 6d 65 6d 62 65 72 est))... (member
e6c0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
e6d0: 61 74 65 20 74 65 73 74 29 20 27 28 22 49 4e 43 ate test) '("INC
e6e0: 4f 4d 50 4c 45 54 45 22 20 22 43 4f 4d 50 4c 45 OMPLETE" "COMPLE
e6f0: 54 45 44 22 29 29 0a 09 09 20 28 6e 6f 74 20 28 TED"))... (not (
e700: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
e710: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 29 get-status test)
e720: 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 41 53 .... '("PAS
e730: 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b S" "WARN" "CHECK
e740: 22 20 22 57 41 49 56 45 44 22 20 22 53 4b 49 50 " "WAIVED" "SKIP
e750: 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 "))))).. prereq
e760: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 s-not-met))..(de
e770: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
e780: 70 72 65 72 65 71 2d 66 61 69 6c 20 70 72 65 72 prereq-fail prer
e790: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 eqs-not-met). (
e7a0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
e7b0: 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 test).. (and
e7c0: 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b (vector? test) ;
e7d0: 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 ; not (string? t
e7e0: 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 6c 3f est))... (equal?
e7f0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
e800: 61 74 65 20 74 65 73 74 29 20 22 4e 4f 54 5f 53 ate test) "NOT_S
e810: 54 41 52 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 TARTED")... (not
e820: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
e830: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
e840: 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 6e t).... '("n
e850: 2f 61 22 20 22 4b 45 45 50 5f 54 52 59 49 4e 47 /a" "KEEP_TRYING
e860: 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 "))))).. prereq
e870: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 s-not-met))..(de
e880: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
e890: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
e8a0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
e8b0: 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 6d (filter. (lam
e8c0: 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 bda (t). (or
e8d0: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 (not (vector? t
e8e0: 29 29 0a 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 )).. (not (membe
e8f0: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
e900: 74 61 74 65 20 74 29 20 27 28 22 49 4e 43 4f 4d tate t) '("INCOM
e910: 50 4c 45 54 45 22 20 22 43 4f 4d 50 4c 45 54 45 PLETE" "COMPLETE
e920: 44 22 29 29 29 29 29 0a 20 20 20 70 72 65 72 65 D"))))). prere
e930: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 3b 3b qs-not-met))..;;
e940: 20 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 (define (runs:c
e950: 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 alc-not-complete
e960: 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 d prereqs-not-me
e970: 74 29 0a 3b 3b 20 20 20 28 66 69 6c 74 65 72 0a t).;; (filter.
e980: 3b 3b 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 ;; (lambda (t
e990: 29 0a 3b 3b 20 20 20 20 20 20 28 6f 72 20 28 6e ).;; (or (n
e9a0: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
e9b0: 3b 3b 20 09 20 28 6e 6f 74 20 28 65 71 75 61 6c ;; . (not (equal
e9c0: 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 ? "COMPLETED" (d
e9d0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
e9e0: 20 74 29 29 29 29 29 0a 3b 3b 20 20 20 20 70 72 t))))).;; pr
e9f0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
ea00: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 .(define (runs:c
ea10: 61 6c 63 2d 72 75 6e 6e 61 62 6c 65 20 70 72 65 alc-runnable pre
ea20: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 reqs-not-met).
ea30: 28 66 69 6c 74 65 72 20 0a 20 20 20 28 6c 61 6d (filter . (lam
ea40: 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 bda (t). (or
ea50: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 (not (vector? t
ea60: 29 29 0a 09 20 28 61 6e 64 20 28 65 71 75 61 6c )).. (and (equal
ea70: 3f 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 ? "NOT_STARTED"
ea80: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
ea90: 74 65 20 74 29 29 0a 09 20 20 20 20 20 20 28 6d te t)).. (m
eaa0: 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
eab0: 65 74 2d 73 74 61 74 75 73 20 74 29 0a 09 09 09 et-status t)....
eac0: 20 20 20 20 20 20 27 28 22 6e 2f 61 22 20 22 4b '("n/a" "K
ead0: 45 45 50 5f 54 52 59 49 4e 47 22 29 29 29 29 29 EEP_TRYING")))))
eae0: 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d . prereqs-not-
eaf0: 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 met))..(define (
eb00: 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 runs:pretty-stri
eb10: 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 ng lst). (map (
eb20: 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 28 69 66 lambda (t).. (if
eb30: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 (not (vector? t
eb40: 29 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 74 )).. (conc t
eb50: 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 28 64 ).. (conc (d
eb60: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
eb70: 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 ame t) ":" (db:t
eb80: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
eb90: 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 "/" (db:test-ge
eba0: 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 0a 20 t-status t)))).
ebb0: 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 3b 3b 20 lst))..;;
ebc0: 70 61 72 65 6e 74 2d 74 65 73 74 20 69 73 20 74 parent-test is t
ebd0: 68 65 72 65 20 61 73 20 61 20 70 6c 61 63 65 68 here as a placeh
ebe0: 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 6e 20 70 older for when p
ebf0: 61 72 65 6e 74 2d 74 65 73 74 73 20 63 61 6e 20 arent-tests can
ec00: 62 65 20 72 75 6e 20 61 73 20 61 20 73 65 74 75 be run as a setu
ec10: 70 20 73 74 65 70 0a 28 64 65 66 69 6e 65 20 28 p step.(define (
ec20: 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 run:test run-id
ec30: 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c 73 run-info keyvals
ec40: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 runname test-re
ec50: 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 65 6e cord flags paren
ec60: 74 2d 74 65 73 74 20 74 65 73 74 2d 72 65 67 69 t-test test-regi
ec70: 73 74 72 79 20 61 6c 6c 2d 74 65 73 74 73 2d 72 stry all-tests-r
ec80: 65 67 69 73 74 72 79 29 0a 20 20 3b 3b 20 41 6c egistry). ;; Al
ec90: 6c 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 67 l these vars mig
eca0: 68 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 64 ht be referenced
ecb0: 20 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e 66 by the testconf
ecc0: 69 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a 20 ig file reader.
ecd0: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 (let* ((test-na
ece0: 6d 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 me (tests:tes
ecf0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
ed00: 61 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f 72 ame test-recor
ed10: 64 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 74 d)).. (test-wait
ed20: 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 ons (tests:testq
ed30: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
ed40: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
ed50: 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 ).. (test-conf
ed60: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
ed70: 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ue-get-testconfi
ed80: 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a g test-record)).
ed90: 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 20 . (itemdat
eda0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
edb0: 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 -get-itemdat
edc0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
edd0: 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 68 (test-path (h
ede0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 61 6c ash-table-ref al
edf0: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
ee00: 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 test-name)) ;;
ee10: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
ee20: 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e "/tests/" test-n
ee30: 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 ame)) ;; could u
ee40: 73 65 20 74 65 73 74 73 3a 67 65 74 2d 74 65 73 se tests:get-tes
ee50: 74 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e tconfig here ...
ee60: 0a 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 20 .. (force
ee70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
ee80: 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 /default flags "
ee90: 2d 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 28 -force" #f)).. (
eea0: 72 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 61 rerun (ha
eeb0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
eec0: 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 72 ault flags "-rer
eed0: 75 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 70 un" #f)).. (keep
eee0: 67 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d 74 going (hash-t
eef0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
ef00: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
ef10: 6e 67 22 20 23 66 29 29 0a 09 20 28 69 6e 63 6f ng" #f)).. (inco
ef20: 6d 70 6c 65 74 65 2d 74 69 6d 65 6f 75 74 20 28 mplete-timeout (
ef30: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
ef40: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
ef50: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
ef60: 73 65 74 75 70 22 20 22 69 6e 63 6f 6d 70 6c 65 setup" "incomple
ef70: 74 65 2d 74 69 6d 65 6f 75 74 22 29 20 22 78 22 te-timeout") "x"
ef80: 29 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 ))).. (item-path
ef90: 20 20 20 20 20 22 22 29 0a 09 20 28 64 62 20 20 "").. (db
efa0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 #f).. (
efb0: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 23 full-test-name #
efc0: 66 29 29 0a 0a 20 20 20 20 3b 3b 20 73 65 74 74 f)).. ;; sett
efd0: 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 ing itemdat to a
efe0: 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 20 23 list if it is #
eff0: 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 f. (if (not i
f000: 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 temdat)(set! ite
f010: 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 mdat '())). (
f020: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 set! item-path (
f030: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path
f040: 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 73 itemdat)). (s
f050: 65 74 21 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 et! full-test-na
f060: 6d 65 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 me (db:test-make
f070: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
f080: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
f090: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
f0a0: 74 2d 69 6e 66 6f 20 34 0a 09 09 20 20 20 20 20 t-info 4...
f0b0: 20 22 5c 6e 54 45 53 54 4e 41 4d 45 3a 20 22 20 "\nTESTNAME: "
f0c0: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 0a full-test-name .
f0d0: 09 09 20 20 20 20 20 20 22 5c 6e 20 20 20 74 65 .. "\n te
f0e0: 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 68 61 st-config: " (ha
f0f0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
f100: 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 20 20 test-conf)...
f110: 20 20 20 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 "\n itemdat
f120: 3a 20 22 20 69 74 65 6d 64 61 74 0a 09 09 20 20 : " itemdat...
f130: 20 20 20 20 29 0a 20 20 20 20 28 64 65 62 75 67 ). (debug
f140: 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 :print 2 "Attemp
f150: 74 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 ting to launch t
f160: 65 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d est " full-test-
f170: 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 74 65 6e name). (seten
f180: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
f190: 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a test-name) ;; .
f1a0: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f (setenv "MT_
f1b0: 49 54 45 4d 50 41 54 48 22 20 20 69 74 65 6d 2d ITEMPATH" item-
f1c0: 70 61 74 68 29 0a 20 20 20 20 28 73 65 74 65 6e path). (seten
f1d0: 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 v "MT_RUNNAME"
f1e0: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 72 runname). (r
f1f0: 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 73 74 uns:set-megatest
f200: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
f210: 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e inrunname: runn
f220: 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 ame) ;; these ma
f230: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
f240: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
f250: 63 65 73 73 0a 20 20 20 20 28 63 68 61 6e 67 65 cess. (change
f260: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
f270: 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 65 ath*).. ;; He
f280: 72 65 20 69 73 20 77 68 65 72 65 20 74 68 65 20 re is where the
f290: 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 test_meta table
f2a0: 69 73 20 62 65 73 74 20 75 70 64 61 74 65 64 0a is best updated.
f2b0: 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 ;; Yes, anot
f2c0: 68 65 72 20 75 73 65 20 6f 66 20 61 20 67 6c 6f her use of a glo
f2d0: 62 61 6c 20 66 6f 72 20 63 61 63 68 69 6e 67 2e bal for caching.
f2e0: 20 4e 65 65 64 20 61 20 62 65 74 74 65 72 20 77 Need a better w
f2f0: 61 79 3f 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b ay?. ;;. ;
f300: 3b 20 54 68 65 72 65 20 69 73 20 6e 6f 77 20 61 ; There is now a
f310: 20 73 69 6e 67 6c 65 20 63 61 6c 6c 20 74 6f 20 single call to
f320: 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d runs:update-all-
f330: 74 65 73 74 5f 6d 65 74 61 20 61 6e 64 20 74 68 test_meta and th
f340: 69 73 20 0a 20 20 20 20 3b 3b 20 70 65 72 2d 74 is . ;; per-t
f350: 65 73 74 20 63 61 6c 6c 20 69 73 20 6e 6f 74 20 est call is not
f360: 6e 65 65 64 65 64 2e 20 47 69 76 65 6e 20 74 68 needed. Given th
f370: 65 20 64 65 6c 69 63 61 63 79 20 6f 66 20 74 68 e delicacy of th
f380: 65 20 6d 6f 76 65 20 74 6f 20 0a 20 20 20 20 3b e move to . ;
f390: 3b 20 76 31 2e 35 35 20 74 68 69 73 20 63 6f 64 ; v1.55 this cod
f3a0: 65 20 69 73 20 62 65 69 6e 67 20 6c 65 66 74 20 e is being left
f3b0: 69 6e 20 70 6c 61 63 65 20 66 6f 72 20 74 68 65 in place for the
f3c0: 20 74 69 6d 65 20 62 65 69 6e 67 2e 0a 20 20 20 time being..
f3d0: 20 3b 3b 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ;;. (if (not
f3e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
f3f0: 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 74 2d 6d /default *test-m
f400: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
f410: 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 t-name #f)).
f420: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 28 (begin.. (
f430: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
f440: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
f450: 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 74 ed* test-name #t
f460: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 75 ). (ru
f470: 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
f480: 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 eta test-name te
f490: 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 0a st-conf))). .
f4a0: 20 20 20 20 3b 3b 20 69 74 65 6d 64 61 74 20 3d ;; itemdat =
f4b0: 3e 20 28 28 72 69 70 65 6e 65 73 73 20 22 6f 76 > ((ripeness "ov
f4c0: 65 72 72 69 70 65 22 29 20 28 74 65 6d 70 65 72 erripe") (temper
f4d0: 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 ature "cool") (s
f4e0: 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 eason "summer"))
f4f0: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 . (let* ((new
f500: 2d 74 65 73 74 2d 70 61 74 68 20 28 73 74 72 69 -test-path (stri
f510: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
f520: 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 20 28 cons test-path (
f530: 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 61 74 map cadr itemdat
f540: 29 29 20 22 2f 22 29 29 0a 09 20 20 20 28 74 65 )) "/")).. (te
f550: 73 74 2d 69 64 20 20 20 20 20 20 20 28 72 6d 74 st-id (rmt
f560: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e :get-test-id run
f570: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
f580: 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 28 74 em-path)).. (t
f590: 65 73 74 64 61 74 20 20 20 20 20 20 20 28 69 66 estdat (if
f5a0: 20 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 test-id (rmt:ge
f5b0: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
f5c0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
f5d0: 29 20 23 66 29 29 29 0a 20 20 20 20 20 20 28 69 ) #f))). (i
f5e0: 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a f (not testdat).
f5f0: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a . (let loop ().
f600: 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 74 . ;; ensure t
f610: 68 61 74 20 74 68 65 20 70 61 74 68 20 65 78 69 hat the path exi
f620: 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 73 sts before regis
f630: 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 0a tering the test.
f640: 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 . ;; NOPE: Ca
f650: 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 nnot! Don't know
f660: 20 79 65 74 20 77 68 69 63 68 20 64 69 73 6b 20 yet which disk
f670: 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 73 area will be ass
f680: 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b igned...... ;
f690: 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 ; (system (conc
f6a0: 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 2d "mkdir -p " new-
f6b0: 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 test-path))..
f6c0: 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 65 ;;.. ;; (ope
f6d0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 n-run-close test
f6e0: 73 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 s:register-test
f6f0: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
f700: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
f710: 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e ;;.. ;; N
f720: 42 2f 2f 20 66 6f 72 20 74 68 65 20 61 62 6f 76 B// for the abov
f730: 65 20 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 74 e line. I want t
f740: 68 65 20 74 65 73 74 20 74 6f 20 62 65 20 72 65 he test to be re
f750: 67 69 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 65 gistered long be
f760: 66 6f 72 65 20 74 68 69 73 20 72 6f 75 74 69 6e fore this routin
f770: 65 20 67 65 74 73 20 63 61 6c 6c 65 64 21 0a 09 e gets called!..
f780: 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 69 66 20 ;;.. (if
f790: 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 28 73 65 (not test-id)(se
f7a0: 74 21 20 74 65 73 74 2d 69 64 20 28 72 6d 74 3a t! test-id (rmt:
f7b0: 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
f7c0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
f7d0: 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 28 m-path))).. (
f7e0: 69 66 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 if (not test-id)
f7f0: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
f800: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 ebug:print 2 "WA
f810: 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 RN: Test not pre
f820: 2d 63 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e -created? test-n
f830: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
f840: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 ", item-path=" i
f850: 74 65 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d tem-path ", run-
f860: 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 id=" run-id)...
f870: 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 74 (rmt:register-t
f880: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
f890: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
f8a0: 09 09 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 .. (set! test-i
f8b0: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
f8c0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
f8d0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
f8e0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
f8f0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 int-info 4 "test
f900: 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c -id=" test-id ",
f910: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
f920: 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 ", test-name="
f930: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 test-name ", ite
f940: 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d m-path=\"" item-
f950: 70 61 74 68 20 22 5c 22 22 29 0a 09 20 20 20 20 path "\"")..
f960: 28 73 65 74 21 20 74 65 73 74 64 61 74 20 28 72 (set! testdat (r
f970: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
f980: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
f990: 73 74 2d 69 64 29 29 0a 09 20 20 20 20 28 69 66 st-id)).. (if
f9a0: 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 (not testdat)..
f9b0: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
f9c0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
f9d0: 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 "WARNING: server
f9e0: 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 is overloaded,
f9f0: 74 72 79 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 trying again in
fa00: 6f 6e 65 20 73 65 63 6f 6e 64 22 29 0a 09 09 20 one second")...
fa10: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
fa20: 31 29 0a 09 09 20 20 28 6c 6f 6f 70 29 29 29 29 1)... (loop))))
fa30: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ). (if (not
fa40: 20 74 65 73 74 64 61 74 29 20 3b 3b 20 73 68 6f testdat) ;; sho
fa50: 75 6c 64 20 4e 4f 54 20 68 61 70 70 65 6e 0a 09 uld NOT happen..
fa60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
fa70: 20 22 45 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 "ERROR: failed
fa80: 74 6f 20 67 65 74 20 74 65 73 74 20 72 65 63 6f to get test reco
fa90: 72 64 20 66 6f 72 20 74 65 73 74 2d 69 64 20 22 rd for test-id "
faa0: 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 test-id)).
fab0: 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 (set! test-id (
fac0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
fad0: 65 73 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 estdat)). (
fae0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
faf0: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 test-path).. (
fb00: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
fb10: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 test-path).. (
fb20: 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 begin.. (debu
fb30: 67 3a 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 g:print "ERROR:
fb40: 74 65 73 74 20 72 75 6e 20 70 61 74 68 20 6e 6f test run path no
fb50: 74 20 63 72 65 61 74 65 64 20 62 65 66 6f 72 65 t created before
fb60: 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 attempting to r
fb70: 75 6e 20 74 68 65 20 74 65 73 74 2e 20 50 65 72 un the test. Per
fb80: 68 61 70 73 20 79 6f 75 20 61 72 65 20 72 75 6e haps you are run
fb90: 6e 69 6e 67 20 2d 72 65 6d 6f 76 65 2d 72 75 6e ning -remove-run
fba0: 73 20 61 74 20 74 68 65 20 73 61 6d 65 20 74 69 s at the same ti
fbb0: 6d 65 3f 22 29 0a 09 20 20 20 20 28 63 68 61 6e me?").. (chan
fbc0: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f ge-directory *to
fbd0: 70 70 61 74 68 2a 29 29 29 0a 20 20 20 20 20 20 ppath*))).
fbe0: 28 63 61 73 65 20 28 69 66 20 66 6f 72 63 65 20 (case (if force
fbf0: 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ;; (args:get-arg
fc00: 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f "-force")...'NO
fc10: 54 5f 53 54 41 52 54 45 44 0a 09 09 28 69 66 20 T_STARTED...(if
fc20: 74 65 73 74 64 61 74 0a 09 09 20 20 20 20 28 73 testdat... (s
fc30: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 tring->symbol (t
fc40: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
fc50: 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 27 66 stdat))... 'f
fc60: 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 ailed-to-insert)
fc70: 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 )..((failed-to-i
fc80: 6e 73 65 72 74 29 0a 09 20 28 64 65 62 75 67 3a nsert).. (debug:
fc90: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
fca0: 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 Failed to insert
fcb0: 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f the record into
fcc0: 20 74 68 65 20 64 62 22 29 29 0a 09 28 28 4e 4f the db"))..((NO
fcd0: 54 5f 53 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 T_STARTED COMPLE
fce0: 54 45 44 20 44 45 4c 45 54 45 44 20 49 4e 43 4f TED DELETED INCO
fcf0: 4d 50 4c 45 54 45 29 0a 09 20 28 6c 65 74 20 28 MPLETE).. (let (
fd00: 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 (runflag #f))..
fd10: 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 (cond.. ;;
fd20: 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d -force, run no m
fd30: 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 atter what..
fd40: 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e (force (set! run
fd50: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
fd60: 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 ; NOT_STARTED, r
fd70: 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 un no matter wha
fd80: 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 72 20 t.. ((member
fd90: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
fda0: 74 65 73 74 64 61 74 29 20 27 28 22 44 45 4c 45 testdat) '("DELE
fdb0: 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 TED" "NOT_STARTE
fdc0: 44 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 29 D" "INCOMPLETE")
fdd0: 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 )(set! runflag #
fde0: 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 t)).. ;; not
fdf0: 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c -rerun and PASS,
fe00: 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 WARN or CHECK,
fe10: 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 do no run.. (
fe20: 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 (and (or (not re
fe30: 72 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 run)... kee
fe40: 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 pgoing)... ;; R
fe50: 65 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 equire to force
fe60: 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c re-run for COMPL
fe70: 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e ETED or *anythin
fe80: 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f g* + PASS,WARN o
fe90: 72 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 r CHECK... (or
fea0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
feb0: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
fec0: 29 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e ) '("PASS" "WARN
fed0: 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 " "CHECK" "SKIP"
fee0: 20 22 57 41 49 56 45 44 22 29 29 0a 09 09 20 20 "WAIVED"))...
fef0: 20 20 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 (member (tes
ff00: 74 3a 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 t:get-state tes
ff10: 74 64 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 tdat) '("COMPLET
ff20: 45 44 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 ED")))) .. (
ff30: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
ff40: 20 32 20 22 72 75 6e 6e 69 6e 67 20 74 65 73 74 2 "running test
ff50: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 " test-name "/"
ff60: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 item-path " sup
ff70: 70 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 pressed as it is
ff80: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
ff90: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 61 6e te testdat) " an
ffa0: 64 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 d " (test:get-st
ffb0: 61 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 atus testdat))..
ffc0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
ffd0: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
ffe0: 74 72 79 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 try full-test-na
fff0: 6d 65 20 27 44 4f 4e 4f 54 52 55 4e 29 20 3b 3b me 'DONOTRUN) ;;
10000 20 43 4f 4d 50 4c 45 54 45 44 29 0a 09 20 20 20 COMPLETED)..
10010 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
10020 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 #f)).. ;; -re
10030 72 75 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 run and status i
10040 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 s one of the spe
10050 63 69 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 cifed, run it..
10060 20 20 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 ((and rerun..
10070 09 20 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e . (let* ((rerun
10080 6c 73 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 lst (string-sp
10090 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a lit rerun ",")).
100a0 09 09 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 ... (must-rerun
100b0 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
100c0 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
100d0 29 20 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 ) rerunlst)))...
100e0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
100f0 2d 69 6e 66 6f 20 33 20 22 2d 72 65 72 75 6e 20 -info 3 "-rerun
10100 6c 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c list: " rerun ",
10110 20 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 test-status: "
10120 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
10130 20 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 testdat)", must
10140 2d 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 -rerun: " must-r
10150 65 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 erun)... must
10160 2d 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 -rerun)).. (
10170 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
10180 20 32 20 22 52 65 72 75 6e 20 66 6f 72 63 65 64 2 "Rerun forced
10190 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
101a0 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
101b0 61 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 ath).. (set!
101c0 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
101d0 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
101e0 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 , do not rerun F
101f0 41 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b AIL.. ((and k
10200 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 eepgoing... (me
10210 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
10220 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
10230 28 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 ("FAIL")))..
10240 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
10250 66 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 f)).. ((and (
10260 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 not rerun)... (
10270 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
10280 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
10290 20 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 '("FAIL" "n/a")
102a0 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
102b0 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
102c0 20 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e (else (set! run
102d0 66 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 flag #f))).. (
102e0 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 52 debug:print 4 "R
102f0 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 UNNING => runfla
10300 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 g: " runflag " S
10310 54 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 TATE: " (test:ge
10320 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
10330 20 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 " STATUS: " (te
10340 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
10350 73 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 stdat)).. (if
10360 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 (not runflag)..
10370 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 (if (not p
10380 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 arent-test)...
10390 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f (if (runs:lowno
103a0 69 73 65 20 28 63 6f 6e 63 20 22 6e 6f 74 20 73 ise (conc "not s
103b0 74 61 72 74 69 6e 67 20 74 65 73 74 22 20 66 75 tarting test" fu
103c0 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 29 20 36 30 ll-test-name) 60
103d0 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 )... (debu
103e0 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a g:print 1 "NOTE:
103f0 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 Not starting te
10400 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e st " full-test-n
10410 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 ame " as it is s
10420 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 tate \"" (test:g
10430 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
10440 29 20 0a 09 09 09 09 20 20 20 20 22 5c 22 20 61 ) ..... "\" a
10450 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 nd status \"" (t
10460 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
10470 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 estdat) "\", use
10480 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 73 -rerun \"" (tes
10490 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
104a0 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 22 5c tdat)..... "\
104b0 22 20 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f " or -force to o
104c0 76 65 72 72 69 64 65 22 29 29 29 0a 09 20 20 20 verride")))..
104d0 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 ;; NOTE: No
104e0 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 63 6b 69 longer be checki
104f0 6e 67 20 70 72 65 72 65 71 75 69 73 69 74 65 73 ng prerequisites
10500 20 68 65 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 here! Will neve
10510 72 20 67 65 74 20 68 65 72 65 20 75 6e 6c 65 73 r get here unles
10520 73 20 70 72 65 72 65 71 73 20 61 72 65 0a 09 20 s prereqs are..
10530 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 61 ;; a
10540 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 lready met...
10550 20 20 20 20 3b 3b 20 54 68 69 73 20 77 6f 75 6c ;; This woul
10560 64 20 62 65 20 61 20 67 72 65 61 74 20 70 6c 61 d be a great pla
10570 63 65 20 74 6f 20 64 6f 20 74 68 65 20 70 72 6f ce to do the pro
10580 63 65 73 73 2d 66 6f 72 6b 0a 09 20 20 20 20 20 cess-fork..
10590 20 20 3b 3b 20 0a 09 20 20 20 20 20 20 20 28 6c ;; .. (l
105a0 65 74 20 28 28 73 6b 69 70 2d 74 65 73 74 20 20 et ((skip-test
105b0 20 23 66 29 0a 09 09 20 20 20 20 20 28 73 6b 69 #f)... (ski
105c0 70 2d 63 68 65 63 6b 20 20 28 63 6f 6e 66 69 67 p-check (config
105d0 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 65 f:get-section te
105e0 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 29 29 st-conf "skip"))
105f0 29 0a 09 09 20 28 63 6f 6e 64 20 0a 09 09 20 20 )... (cond ...
10600 3b 3b 20 48 61 76 65 20 74 6f 20 63 68 65 63 6b ;; Have to check
10610 20 66 6f 72 20 73 6b 69 70 20 63 6f 6e 64 69 74 for skip condit
10620 69 6f 6e 73 2e 20 54 68 69 73 20 6f 6e 65 20 73 ions. This one s
10630 6b 69 70 73 20 69 66 20 74 68 65 72 65 20 61 72 kips if there ar
10640 65 20 73 61 6d 65 2d 6e 61 6d 65 64 20 74 65 73 e same-named tes
10650 74 73 0a 09 09 20 20 3b 3b 20 63 75 72 72 65 6e ts... ;; curren
10660 74 6c 79 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 tly running...
10670 28 28 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b ((and skip-check
10680 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ....(configf:loo
10690 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 kup test-conf "s
106a0 6b 69 70 22 20 22 70 72 65 76 72 75 6e 6e 69 6e kip" "prevrunnin
106b0 67 22 29 29 0a 09 09 20 20 20 3b 3b 20 72 75 6e g"))... ;; run
106c0 2d 69 64 73 20 3d 20 23 66 20 6d 65 61 6e 73 20 -ids = #f means
106d0 2a 61 6c 6c 2a 20 72 75 6e 73 0a 09 09 20 20 20 *all* runs...
106e0 28 6c 65 74 20 28 28 72 75 6e 6e 69 6e 67 2d 74 (let ((running-t
106f0 65 73 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 ests (rmt:get-te
10700 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e sts-for-runs-min
10710 64 61 74 61 20 23 66 20 66 75 6c 6c 2d 74 65 73 data #f full-tes
10720 74 2d 6e 61 6d 65 20 27 28 22 52 55 4e 4e 49 4e t-name '("RUNNIN
10730 47 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 G" "REMOTEHOSTST
10740 41 52 54 22 20 22 4c 41 55 4e 43 48 45 44 22 29 ART" "LAUNCHED")
10750 20 27 28 29 20 23 66 29 29 29 0a 09 09 20 20 20 '() #f)))...
10760 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
10770 3f 20 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 29 ? running-tests)
10780 29 20 3b 3b 20 68 61 76 65 20 74 6f 20 73 6b 69 ) ;; have to ski
10790 70 20 0a 09 09 09 20 28 73 65 74 21 20 73 6b 69 p .... (set! ski
107a0 70 2d 74 65 73 74 20 22 53 6b 69 70 70 69 6e 67 p-test "Skipping
107b0 20 64 75 65 20 74 6f 20 70 72 65 76 69 6f 75 73 due to previous
107c0 20 74 65 73 74 73 20 72 75 6e 6e 69 6e 67 22 29 tests running")
107d0 29 29 29 0a 09 09 20 20 28 28 61 6e 64 20 73 6b )))... ((and sk
107e0 69 70 2d 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e ip-check....(con
107f0 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 figf:lookup test
10800 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 69 -conf "skip" "fi
10810 6c 65 65 78 69 73 74 73 22 29 29 0a 09 09 20 20 leexists"))...
10820 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
10830 73 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b s? (configf:look
10840 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b up test-conf "sk
10850 69 70 22 20 22 66 69 6c 65 65 78 69 73 74 73 22 ip" "fileexists"
10860 29 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 74 ))... (set
10870 21 20 73 6b 69 70 2d 74 65 73 74 20 28 63 6f 6e ! skip-test (con
10880 63 20 22 53 6b 69 70 70 69 6e 67 20 64 75 65 20 c "Skipping due
10890 74 6f 20 65 78 69 73 74 61 6e 63 65 20 6f 66 20 to existance of
108a0 66 69 6c 65 20 22 20 28 63 6f 6e 66 69 67 66 3a file " (configf:
108b0 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 lookup test-conf
108c0 20 22 73 6b 69 70 22 20 22 66 69 6c 65 65 78 69 "skip" "fileexi
108d0 73 74 73 22 29 29 29 29 29 0a 0a 09 09 20 20 28 sts"))))).... (
108e0 28 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a (and skip-check.
108f0 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b ...(configf:look
10900 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b up test-conf "sk
10910 69 70 22 20 22 72 75 6e 64 65 6c 61 79 22 29 29 ip" "rundelay"))
10920 0a 09 09 20 20 20 3b 3b 20 72 75 6e 2d 69 64 73 ... ;; run-ids
10930 20 3d 20 23 66 20 6d 65 61 6e 73 20 2a 61 6c 6c = #f means *all
10940 2a 20 72 75 6e 73 0a 09 09 20 20 20 28 6c 65 74 * runs... (let
10950 2a 20 28 28 6e 75 6d 73 65 63 6f 6e 64 73 20 20 * ((numseconds
10960 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d (common:hms-
10970 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 string->seconds
10980 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
10990 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 test-conf "skip"
109a0 20 22 72 75 6e 64 65 6c 61 79 22 29 29 29 0a 09 "rundelay")))..
109b0 09 09 20 20 28 72 75 6e 6e 69 6e 67 2d 74 65 73 .. (running-tes
109c0 74 73 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 ts (rmt:get-te
109d0 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e sts-for-runs-min
109e0 64 61 74 61 20 23 66 20 66 75 6c 6c 2d 74 65 73 data #f full-tes
109f0 74 2d 6e 61 6d 65 20 27 28 22 52 55 4e 4e 49 4e t-name '("RUNNIN
10a00 47 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 G" "REMOTEHOSTST
10a10 41 52 54 22 20 22 4c 41 55 4e 43 48 45 44 22 29 ART" "LAUNCHED")
10a20 20 27 28 29 20 23 66 29 29 0a 09 09 09 20 20 28 '() #f)).... (
10a30 63 6f 6d 70 6c 65 74 65 64 2d 74 65 73 74 73 20 completed-tests
10a40 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (rmt:get-tests-f
10a50 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 61 20 or-runs-mindata
10a60 23 66 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d #f full-test-nam
10a70 65 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 e '("COMPLETED"
10a80 22 49 4e 43 4f 4d 50 4c 45 54 45 22 29 20 27 28 "INCOMPLETE") '(
10a90 22 50 41 53 53 22 20 22 46 41 49 4c 22 20 22 41 "PASS" "FAIL" "A
10aa0 42 4f 52 54 22 29 20 23 66 29 29 20 3b 3b 20 69 BORT") #f)) ;; i
10ab0 72 6f 6e 69 63 61 6c 6c 79 20 49 4e 43 4f 4d 50 ronically INCOMP
10ac0 4c 45 54 45 20 69 73 20 73 61 6d 65 20 61 73 20 LETE is same as
10ad0 43 4f 4d 50 4c 45 54 45 44 20 69 6e 20 74 68 69 COMPLETED in thi
10ae0 73 20 63 6f 6e 74 65 78 0a 09 09 09 20 20 28 6c s contex.... (l
10af0 61 73 74 2d 72 75 6e 2d 74 69 6d 65 73 20 20 28 ast-run-times (
10b00 6d 61 70 20 64 62 3a 6d 69 6e 74 65 73 74 2d 67 map db:mintest-g
10b10 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 63 6f et-event_time co
10b20 6d 70 6c 65 74 65 64 2d 74 65 73 74 73 29 29 0a mpleted-tests)).
10b30 09 09 09 20 20 28 74 69 6d 65 2d 73 69 6e 63 65 ... (time-since
10b40 2d 6c 61 73 74 20 28 2d 20 28 63 75 72 72 65 6e -last (- (curren
10b50 74 2d 73 65 63 6f 6e 64 73 29 20 28 69 66 20 28 t-seconds) (if (
10b60 6e 75 6c 6c 3f 20 6c 61 73 74 2d 72 75 6e 2d 74 null? last-run-t
10b70 69 6d 65 73 29 20 30 20 28 61 70 70 6c 79 20 6d imes) 0 (apply m
10b80 61 78 20 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 ax last-run-time
10b90 73 29 29 29 29 29 0a 09 09 20 20 20 20 20 28 69 s)))))... (i
10ba0 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
10bb0 3f 20 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 29 ? running-tests)
10bc0 29 20 3b 3b 20 68 61 76 65 20 74 6f 20 73 6b 69 ) ;; have to ski
10bd0 70 20 69 66 20 74 65 73 74 20 69 73 20 72 75 6e p if test is run
10be0 6e 69 6e 67 0a 09 09 09 20 20 20 20 20 28 3e 20 ning.... (>
10bf0 6e 75 6d 73 65 63 6f 6e 64 73 20 74 69 6d 65 2d numseconds time-
10c00 73 69 6e 63 65 2d 6c 61 73 74 29 29 0a 09 09 09 since-last))....
10c10 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 74 (set! skip-test
10c20 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 6e 67 (conc "Skipping
10c30 20 64 75 65 20 74 6f 20 70 72 65 76 69 6f 75 73 due to previous
10c40 20 74 65 73 74 20 72 75 6e 20 6c 65 73 73 20 74 test run less t
10c50 68 61 6e 20 22 20 28 63 6f 6e 66 69 67 66 3a 6c han " (configf:l
10c60 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
10c70 22 73 6b 69 70 22 20 22 72 75 6e 64 65 6c 61 79 "skip" "rundelay
10c80 22 29 20 22 20 61 67 6f 22 29 29 29 29 29 29 0a ") " ago")))))).
10c90 09 09 20 0a 09 09 20 28 69 66 20 73 6b 69 70 2d .. ... (if skip-
10ca0 74 65 73 74 0a 09 09 20 20 20 20 20 28 62 65 67 test... (beg
10cb0 69 6e 0a 09 09 20 20 20 20 20 20 20 28 6d 74 3a in... (mt:
10cc0 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
10cd0 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d tatus-by-id run-
10ce0 69 64 20 74 65 73 74 2d 69 64 20 22 43 4f 4d 50 id test-id "COMP
10cf0 4c 45 54 45 44 22 20 22 53 4b 49 50 22 20 73 6b LETED" "SKIP" sk
10d00 69 70 2d 74 65 73 74 29 0a 09 09 20 20 20 20 20 ip-test)...
10d10 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
10d20 6e 66 6f 20 31 20 22 53 4b 49 50 50 49 4e 47 20 nfo 1 "SKIPPING
10d30 54 65 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 Test " full-test
10d40 2d 6e 61 6d 65 20 22 20 64 75 65 20 74 6f 20 22 -name " due to "
10d50 20 73 6b 69 70 2d 74 65 73 74 29 29 0a 09 09 20 skip-test))...
10d60 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 (if (not (la
10d70 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 2d 69 unch-test test-i
10d80 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 d run-id run-inf
10d90 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d o keyvals runnam
10da0 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 73 74 e test-conf test
10db0 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 -name test-path
10dc0 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 29 0a itemdat flags)).
10dd0 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 20 ... (begin....
10de0 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
10df0 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
10e00 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 the test. Exiti
10e10 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f ng as soon as po
10e20 73 73 69 62 6c 65 22 29 0a 09 09 09 20 20 20 28 ssible").... (
10e30 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 set! *globalexit
10e40 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 status* 1) ;; ..
10e50 09 09 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 .. (process-si
10e60 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 gnal (current-pr
10e70 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c ocess-id) signal
10e80 2f 6b 69 6c 6c 29 29 29 29 29 29 29 29 0a 09 28 /kill))))))))..(
10e90 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 (KILLED) .. (deb
10ea0 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
10eb0 3a 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 : " full-test-na
10ec0 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 me " is already
10ed0 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 running or was e
10ee0 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c xplictly killed,
10ef0 20 75 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c use -force to l
10f00 61 75 6e 63 68 20 69 74 2e 22 29 0a 09 20 28 68 aunch it.").. (h
10f10 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
10f20 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 est-registry (db
10f30 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
10f40 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 name test-name t
10f50 65 73 74 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 est-path) 'DONOT
10f60 52 55 4e 29 29 20 3b 3b 20 4b 49 4c 4c 45 44 29 RUN)) ;; KILLED)
10f70 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 )..((LAUNCHED RE
10f80 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 MOTEHOSTSTART RU
10f90 4e 4e 49 4e 47 29 20 20 0a 09 20 28 64 65 62 75 NNING) .. (debu
10fa0 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a g:print 2 "NOTE:
10fb0 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 " test-name " i
10fc0 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e s already runnin
10fd0 67 22 29 29 0a 09 3b 3b 20 28 69 66 20 28 3e 20 g"))..;; (if (>
10fe0 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
10ff0 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d nds)(+ (db:test-
11000 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 get-event_time t
11010 65 73 74 64 61 74 29 0a 09 3b 3b 20 09 09 09 20 estdat)..;; ...
11020 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
11030 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 et-run_duration
11040 74 65 73 74 64 61 74 29 29 29 0a 09 3b 3b 20 09 testdat)))..;; .
11050 28 6f 72 20 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 (or incomplete-t
11060 69 6d 65 6f 75 74 0a 09 3b 3b 20 09 20 20 20 20 imeout..;; .
11070 36 30 30 30 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6000)) ;; i.e. n
11080 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 o update for mor
11090 65 20 74 68 61 6e 20 36 30 30 30 20 73 65 63 6f e than 6000 seco
110a0 6e 64 73 0a 09 3b 3b 20 20 20 20 20 20 28 62 65 nds..;; (be
110b0 67 69 6e 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 gin..;; (
110c0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
110d0 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 ARNING: Test " t
110e0 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 est-name " appea
110f0 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 rs to be dead. F
11100 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 orcing it to sta
11110 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e te INCOMPLETE an
11120 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 d status STUCK/D
11130 45 41 44 22 29 0a 09 3b 3b 20 20 20 20 20 20 20 EAD")..;;
11140 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
11150 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 -status! run-id
11160 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c test-id "INCOMPL
11170 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 ETE" "STUCK/DEAD
11180 22 20 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 " "" #f))..;;
11190 20 20 20 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 ;; (tests:t
111a0 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
111b0 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c test-id "INCOMPL
111c0 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 ETE" "STUCK/DEAD
111d0 22 20 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 " "" #f))..;;
111e0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
111f0 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 2 "NOTE: " test-
11200 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 name " is alread
11210 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 y running")))..(
11220 65 6c 73 65 20 20 20 20 20 20 0a 09 20 28 64 65 else .. (de
11230 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
11240 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 OR: Failed to la
11250 75 6e 63 68 20 74 65 73 74 20 22 20 66 75 6c 6c unch test " full
11260 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e -test-name ". Un
11270 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 recognised state
11280 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
11290 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 te testdat)).. (
112a0 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
112b0 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
112c0 74 61 74 65 20 74 65 73 74 64 61 74 29 29 20 0a tate testdat)) .
112d0 09 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 20 . ((COMPLETED
112e0 49 4e 43 4f 4d 50 4c 45 54 45 29 0a 09 20 20 20 INCOMPLETE)..
112f0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
11300 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
11310 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
11320 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
11330 65 20 74 65 73 74 2d 70 61 74 68 29 20 27 44 4f e test-path) 'DO
11340 4e 4f 54 52 55 4e 29 29 0a 09 20 20 20 28 65 6c NOTRUN)).. (el
11350 73 65 0a 09 20 20 20 20 28 68 61 73 68 2d 74 61 se.. (hash-ta
11360 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
11370 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d gistry (db:test-
11380 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 make-full-name t
11390 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 est-name test-pa
113a0 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 29 th) 'DONOTRUN)))
113b0 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
113c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
11400 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 ;; END OF NEW ST
11410 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d UFF.;;==========
11420 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11430 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11440 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11450 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
11460 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 efine (get-dir-u
11470 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 p-n dir . params
11480 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 ) . (let ((dpar
11490 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ts (string-spli
114a0 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f t dir "/"))..(co
114b0 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f unt (if (null?
114c0 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 params) 1 (car
114d0 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 params)))). (
114e0 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 conc "/" (string
114f0 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 -intersperse ..
11500 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 (take dpar
11510 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 ts (- (length dp
11520 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 arts) count))..
11530 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a 0a 28 "/"))))..(
11540 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 63 define (runs:rec
11550 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d 77 69 ursive-delete-wi
11560 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 72 65 61 th-error-msg rea
11570 6c 2d 64 69 72 29 0a 20 20 28 69 66 20 28 3e 20 l-dir). (if (>
11580 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
11590 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 72 m -rf " real-dir
115a0 29 29 20 30 29 0a 20 20 20 20 20 20 28 62 65 67 )) 0). (beg
115b0 69 6e 0a 09 3b 3b 20 46 41 49 4c 45 44 2c 20 70 in..;; FAILED, p
115c0 6f 73 73 69 62 6c 79 20 64 75 65 20 74 6f 20 70 ossibly due to p
115d0 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 6f 20 63 ermissions, do c
115e0 68 6d 6f 64 20 61 2b 72 77 78 20 74 68 65 6e 20 hmod a+rwx then
115f0 74 72 79 20 6f 6e 65 20 6d 6f 72 65 20 74 69 6d try one more tim
11600 65 0a 09 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 e..(system (conc
11610 20 22 63 68 6d 6f 64 20 2d 52 20 61 2b 72 77 78 "chmod -R a+rwx
11620 20 22 20 72 65 61 6c 2d 64 69 72 29 29 0a 09 28 " real-dir))..(
11630 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 63 if (> (system (c
11640 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 65 onc "rm -rf " re
11650 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 20 20 20 al-dir)) 0)..
11660 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
11670 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 61 "ERROR: There wa
11680 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f s a problem remo
11690 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 20 ving " real-dir
116a0 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 29 " with rm -f")))
116b0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
116c0 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d 74 65 s:safe-delete-te
116d0 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 72 29 st-dir real-dir)
116e0 0a 20 20 3b 3b 20 66 69 72 73 74 20 64 65 6c 65 . ;; first dele
116f0 74 65 20 61 6c 6c 20 73 75 62 2d 64 69 72 65 63 te all sub-direc
11700 74 6f 72 69 65 73 0a 20 20 28 64 69 72 65 63 74 tories. (direct
11710 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 28 6c 61 ory-fold . (la
11720 6d 62 64 61 20 28 66 20 78 29 0a 20 20 20 20 20 mbda (f x).
11730 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 6d 65 20 (let ((fullname
11740 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 72 20 22 (conc real-dir "
11750 2f 22 20 66 29 29 29 0a 20 20 20 20 20 20 20 28 /" f))). (
11760 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 66 if (directory? f
11770 75 6c 6c 6e 61 6d 65 29 28 72 75 6e 73 3a 72 65 ullname)(runs:re
11780 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d 77 cursive-delete-w
11790 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 66 75 ith-error-msg fu
117a0 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 28 llname))). (
117b0 2b 20 31 20 78 29 29 0a 20 20 20 30 20 72 65 61 + 1 x)). 0 rea
117c0 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 68 65 6e l-dir). ;; then
117d0 20 66 69 6c 65 73 20 6f 74 68 65 72 20 74 68 61 files other tha
117e0 6e 20 2a 74 65 73 74 64 61 74 2e 64 62 2a 0a 20 n *testdat.db*.
117f0 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 (directory-fold
11800 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 20 . (lambda (f
11810 78 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 66 x). (let ((f
11820 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 72 65 ullname (conc re
11830 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 29 29 0a al-dir "/" f))).
11840 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
11850 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 28 (string-search (
11860 72 65 67 65 78 70 20 22 74 65 73 74 64 61 74 2e regexp "testdat.
11870 64 62 22 29 20 66 29 29 0a 09 20 20 20 28 72 75 db") f)).. (ru
11880 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 65 6c ns:recursive-del
11890 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d ete-with-error-m
118a0 73 67 20 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 sg fullname))).
118b0 20 20 20 20 28 2b 20 31 20 78 29 29 0a 20 20 20 (+ 1 x)).
118c0 30 20 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 0 real-dir). ;;
118d0 20 74 68 65 6e 20 74 68 65 20 65 6e 74 69 72 65 then the entire
118e0 20 64 69 72 65 63 74 6f 72 79 0a 20 20 28 72 75 directory. (ru
118f0 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 65 6c ns:recursive-del
11900 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d ete-with-error-m
11910 73 67 20 72 65 61 6c 2d 64 69 72 29 29 0a 0a 3b sg real-dir))..;
11920 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b ; Remove runs.;;
11930 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 73 fields are pass
11940 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 0a ing in through .
11950 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 ;; action:.;;
11960 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 'remove-runs.;;
11970 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d 73 'set-state-s
11980 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f tatus.;;.;; NB//
11990 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e 20 should pass in
119a0 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 keys?.;;.(define
119b0 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f (runs:operate-o
119c0 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 74 20 n action target
119d0 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 74 runnamepatt test
119e0 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 74 patt #!key (stat
119f0 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 29 e #f)(status #f)
11a00 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 (new-state-statu
11a10 73 20 23 66 29 28 6d 6f 64 65 20 27 72 65 6d 6f s #f)(mode 'remo
11a20 76 65 2d 61 6c 6c 29 28 6f 70 74 69 6f 6e 73 20 ve-all)(options
11a30 27 28 29 29 29 0a 20 20 28 63 6f 6d 6d 6f 6e 3a '())). (common:
11a40 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 3b 3b clear-caches) ;;
11a50 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 68 65 clear all cache
11a60 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 s. (let* ((db
11a70 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 #f).. (
11a80 74 64 62 64 61 74 20 20 20 20 20 20 20 28 74 61 tdbdat (ta
11a90 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 0a 09 20 sks:open-db))..
11aa0 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 72 (keys (r
11ab0 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 mt:get-keys))..
11ac0 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 28 6d (rundat (m
11ad0 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 t:get-runs-by-pa
11ae0 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 tt keys runnamep
11af0 61 74 74 20 74 61 72 67 65 74 29 29 0a 09 20 28 att target)).. (
11b00 68 65 61 64 65 72 20 20 20 20 20 20 20 28 76 65 header (ve
11b10 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
11b20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 0)).. (runs
11b30 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
11b40 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 73 74 rundat 1)).. (st
11b50 61 74 65 73 20 20 20 20 20 20 20 28 69 66 20 73 ates (if s
11b60 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d 73 70 tate (string-sp
11b70 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 29 20 lit state ",")
11b80 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 73 65 '())).. (statuse
11b90 73 20 20 20 20 20 28 69 66 20 73 74 61 74 75 73 s (if status
11ba0 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 (string-split s
11bb0 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 29 29 tatus ",") '()))
11bc0 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 75 73 .. (state-status
11bd0 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 (if (string? ne
11be0 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 w-state-status)
11bf0 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 (string-split ne
11c00 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 22 w-state-status "
11c10 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 29 0a ,") '(#f #f)))).
11c20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
11c30 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 -info 4 "runs:op
11c40 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 61 64 erate-on => Head
11c50 65 72 3a 20 22 20 68 65 61 64 65 72 20 22 20 61 er: " header " a
11c60 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 ction: " action
11c70 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 " new-state-stat
11c80 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 65 2d us: " new-state-
11c90 73 74 61 74 75 73 29 0a 20 20 20 20 28 69 66 20 status). (if
11ca0 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 73 74 61 (> 2 (length sta
11cb0 74 65 2d 73 74 61 74 75 73 29 29 0a 09 28 62 65 te-status))..(be
11cc0 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
11cd0 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 68 int 0 "ERROR: th
11ce0 65 20 70 61 72 61 6d 65 74 65 72 20 74 6f 20 2d e parameter to -
11cf0 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
11d00 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 65 6c 69 is a comma deli
11d10 6d 69 74 65 64 20 73 74 72 69 6e 67 2e 20 45 2e mited string. E.
11d20 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c 46 41 49 g. COMPLETED,FAI
11d30 4c 22 29 0a 09 20 20 28 65 78 69 74 29 29 29 0a L").. (exit))).
11d40 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
11d50 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 (lambda (run)
11d60 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 . (let ((r
11d70 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e unkey (string-in
11d80 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
11d90 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 lambda (k)......
11da0 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 .(db:get-value-b
11db0 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
11dc0 64 65 72 20 6b 29 29 20 6b 65 79 73 29 20 22 2f der k)) keys) "/
11dd0 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 73 2d ")).. (dirs-
11de0 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b 65 2d to-remove (make-
11df0 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 hash-table))..
11e00 20 20 20 28 70 72 6f 63 2d 67 65 74 2d 74 65 73 (proc-get-tes
11e10 74 73 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d ts (lambda (run-
11e20 69 64 29 0a 09 09 09 20 20 20 20 20 20 28 6d 74 id).... (mt
11e30 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
11e40 75 6e 20 72 75 6e 2d 69 64 0a 09 09 09 09 09 09 un run-id.......
11e50 20 20 20 20 74 65 73 74 70 61 74 74 20 73 74 61 testpatt sta
11e60 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 tes statuses....
11e70 09 09 09 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 ... not-in:
11e80 23 66 0a 09 09 09 09 09 09 20 20 20 20 73 6f 72 #f....... sor
11e90 74 2d 62 79 3a 20 28 63 61 73 65 20 61 63 74 69 t-by: (case acti
11ea0 6f 6e 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 on........
11eb0 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 ((remove-runs)
11ec0 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 09 09 'rundir)........
11ed0 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
11ee0 20 20 20 20 20 20 27 65 76 65 6e 74 5f 74 69 6d 'event_tim
11ef0 65 29 29 29 29 29 29 0a 09 20 28 6c 65 74 2a 20 e)))))).. (let*
11f00 28 28 72 75 6e 2d 69 64 20 20 20 20 28 64 62 3a ((run-id (db:
11f10 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
11f20 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
11f30 69 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 74 61 id"))...(run-sta
11f40 74 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 te (db:get-value
11f50 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
11f60 65 61 64 65 72 20 22 73 74 61 74 65 22 29 29 0a eader "state")).
11f70 09 09 28 72 75 6e 2d 6e 61 6d 65 20 20 28 64 62 ..(run-name (db
11f80 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
11f90 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
11fa0 22 72 75 6e 6e 61 6d 65 22 29 29 0a 09 09 28 74 "runname"))...(t
11fb0 65 73 74 73 20 20 20 20 20 28 69 66 20 28 6e 6f ests (if (no
11fc0 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 t (equal? run-st
11fd0 61 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 ate "locked"))..
11fe0 09 09 20 20 20 20 20 20 20 28 70 72 6f 63 2d 67 .. (proc-g
11ff0 65 74 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 29 et-tests run-id)
12000 0a 09 09 09 20 20 20 20 20 20 20 27 28 29 29 29 .... '()))
12010 0a 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f ...(lasttpath "/
12020 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 does/not/exist/I
12030 2f 68 6f 70 65 22 29 0a 09 09 28 77 6f 72 6b 65 /hope")...(worke
12040 72 2d 74 68 72 65 61 64 20 23 66 29 29 0a 09 20 r-thread #f))..
12050 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
12060 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 nfo 4 "runs:oper
12070 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 72 75 6e ate-on run=" run
12080 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 ", header=" hea
12090 64 65 72 29 0a 09 20 20 20 28 69 66 20 28 6e 6f der).. (if (no
120a0 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 29 t (null? tests))
120b0 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
120c0 09 09 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a .. (case action.
120d0 09 09 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 .. ((remove-ru
120e0 6e 73 29 0a 09 09 20 20 20 20 28 69 66 20 28 74 ns)... (if (t
120f0 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 76 65 72 asks:need-server
12100 20 72 75 6e 2d 69 64 29 28 74 61 73 6b 73 3a 73 run-id)(tasks:s
12110 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f tart-and-wait-fo
12120 72 2d 73 65 72 76 65 72 20 74 64 62 64 61 74 20 r-server tdbdat
12130 72 75 6e 2d 69 64 20 31 30 29 29 0a 09 09 20 20 run-id 10))...
12140 20 20 3b 3b 20 73 65 65 6b 20 61 6e 64 20 6b 69 ;; seek and ki
12150 6c 6c 20 69 6e 20 66 6c 69 67 68 74 20 2d 72 75 ll in flight -ru
12160 6e 74 65 73 74 73 20 77 69 74 68 20 25 20 61 73 ntests with % as
12170 20 74 65 73 74 70 61 74 74 20 68 65 72 65 0a 09 testpatt here..
12180 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
12190 20 74 65 73 74 70 61 74 74 20 22 25 22 29 0a 09 testpatt "%")..
121a0 09 09 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 ..(tasks:kill-ru
121b0 6e 6e 65 72 20 74 61 72 67 65 74 20 72 75 6e 2d nner target run-
121c0 6e 61 6d 65 29 0a 09 09 09 28 64 65 62 75 67 3a name)....(debug:
121d0 70 72 69 6e 74 20 30 20 22 6e 6f 74 20 61 74 74 print 0 "not att
121e0 65 6d 70 74 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 empting to kill
121f0 61 6e 79 20 72 75 6e 20 6c 61 75 6e 63 68 65 72 any run launcher
12200 20 70 72 6f 63 65 73 73 65 73 20 61 73 20 74 65 processes as te
12210 73 74 70 61 74 74 20 69 73 20 22 20 74 65 73 74 stpatt is " test
12220 70 61 74 74 29 29 0a 09 09 20 20 20 20 28 64 65 patt))... (de
12230 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
12240 6f 76 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 oving tests for
12250 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 run: " runkey "
12260 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d " (db:get-value-
12270 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
12280 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 ader "runname"))
12290 29 0a 09 09 20 20 20 28 28 73 65 74 2d 73 74 61 )... ((set-sta
122a0 74 65 2d 73 74 61 74 75 73 29 0a 09 09 20 20 20 te-status)...
122b0 20 28 69 66 20 28 74 61 73 6b 73 3a 6e 65 65 64 (if (tasks:need
122c0 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 28 -server run-id)(
122d0 74 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 2d tasks:start-and-
122e0 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 20 wait-for-server
122f0 74 64 62 64 61 74 20 72 75 6e 2d 69 64 20 31 30 tdbdat run-id 10
12300 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a ))... (debug:
12310 70 72 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 print 1 "Modifyi
12320 6e 67 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 ng state and sta
12330 75 73 20 66 6f 72 20 74 65 73 74 73 20 66 6f 72 us for tests for
12340 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 run: " runkey "
12350 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 " (db:get-value
12360 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
12370 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 eader "runname")
12380 29 29 0a 09 09 20 20 20 28 28 70 72 69 6e 74 2d ))... ((print-
12390 72 75 6e 29 0a 09 09 20 20 20 20 28 64 65 62 75 run)... (debu
123a0 67 3a 70 72 69 6e 74 20 31 20 22 50 72 69 6e 74 g:print 1 "Print
123b0 69 6e 67 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e ing info for run
123c0 20 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e " runkey ", run
123d0 3d 22 20 72 75 6e 20 22 2c 20 74 65 73 74 73 3d =" run ", tests=
123e0 22 20 74 65 73 74 73 20 22 2c 20 68 65 61 64 65 " tests ", heade
123f0 72 3d 22 20 68 65 61 64 65 72 29 0a 09 09 20 20 r=" header)...
12400 20 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 action)... (
12410 28 72 75 6e 2d 77 61 69 74 29 0a 09 09 20 20 20 (run-wait)...
12420 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
12430 22 57 61 69 74 69 6e 67 20 66 6f 72 20 72 75 6e "Waiting for run
12440 20 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e " runkey ", run
12450 3d 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 22 =" runnamepatt "
12460 20 74 6f 20 63 6f 6d 70 6c 65 74 65 22 29 29 0a to complete")).
12470 09 09 20 20 20 28 28 61 72 63 68 69 76 65 29 0a .. ((archive).
12480 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
12490 6e 74 20 31 20 22 41 72 63 68 69 76 69 6e 67 2f nt 1 "Archiving/
124a0 72 65 73 74 6f 72 69 6e 67 20 28 22 20 28 61 72 restoring (" (ar
124b0 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 63 gs:get-arg "-arc
124c0 68 69 76 65 22 29 20 22 29 20 64 61 74 61 20 66 hive") ") data f
124d0 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 or run: " runkey
124e0 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
124f0 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
12500 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
12510 22 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 "))... (set!
12520 77 6f 72 6b 65 72 2d 74 68 72 65 61 64 20 28 6d worker-thread (m
12530 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
12540 64 61 20 28 29 0a 09 09 09 09 09 09 20 20 20 20 da ().......
12550 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
12560 2d 3e 73 79 6d 62 6f 6c 20 28 61 72 67 73 3a 67 ->symbol (args:g
12570 65 74 2d 61 72 67 20 22 2d 61 72 63 68 69 76 65 et-arg "-archive
12580 22 29 29 0a 09 09 09 09 09 09 09 20 28 28 73 61 "))........ ((sa
12590 76 65 20 73 61 76 65 2d 72 65 6d 6f 76 65 20 6b ve save-remove k
125a0 65 65 70 2d 68 74 6d 6c 29 28 61 72 63 68 69 76 eep-html)(archiv
125b0 65 3a 72 75 6e 2d 62 75 70 20 28 61 72 67 73 3a e:run-bup (args:
125c0 67 65 74 2d 61 72 67 20 22 2d 61 72 63 68 69 76 get-arg "-archiv
125d0 65 22 29 20 72 75 6e 2d 69 64 20 72 75 6e 2d 6e e") run-id run-n
125e0 61 6d 65 20 74 65 73 74 73 29 29 0a 09 09 09 09 ame tests)).....
125f0 09 09 09 20 28 28 72 65 73 74 6f 72 65 29 28 61 ... ((restore)(a
12600 72 63 68 69 76 65 3a 62 75 70 2d 72 65 73 74 6f rchive:bup-resto
12610 72 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 re (args:get-arg
12620 20 22 2d 61 72 63 68 69 76 65 22 29 20 72 75 6e "-archive") run
12630 2d 69 64 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 -id run-name tes
12640 74 73 29 29 0a 09 09 09 09 09 09 09 20 28 65 6c ts))........ (el
12650 73 65 20 0a 09 09 09 09 09 09 09 20 20 28 64 65 se ........ (de
12660 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
12670 4f 52 3a 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 OR: unrecognised
12680 20 73 75 62 20 63 6f 6d 6d 61 6e 64 20 74 6f 20 sub command to
12690 2d 61 72 63 68 69 76 65 2e 20 52 75 6e 20 5c 22 -archive. Run \"
126a0 6d 65 67 61 74 65 73 74 5c 22 20 74 6f 20 73 65 megatest\" to se
126b0 65 20 68 65 6c 70 22 29 0a 09 09 09 09 09 09 09 e help")........
126c0 20 20 28 65 78 69 74 29 29 29 29 0a 09 09 09 09 (exit)))).....
126d0 09 09 20 20 20 20 20 22 61 72 63 68 69 76 65 2d .. "archive-
126e0 62 75 70 2d 74 68 72 65 61 64 22 29 29 0a 09 09 bup-thread"))...
126f0 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
12700 74 21 20 77 6f 72 6b 65 72 2d 74 68 72 65 61 64 t! worker-thread
12710 29 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 ))... (else...
12720 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
12730 2d 69 6e 66 6f 20 30 20 22 61 63 74 69 6f 6e 20 -info 0 "action
12740 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 64 20 22 not recognised "
12750 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 20 0a 09 action)))... ..
12760 09 20 3b 3b 20 61 63 74 69 6f 6e 73 20 74 68 61 . ;; actions tha
12770 74 20 6f 70 65 72 61 74 65 20 6f 6e 20 6f 6e 65 t operate on one
12780 20 74 65 73 74 20 61 74 20 61 20 74 69 6d 65 20 test at a time
12790 63 61 6e 20 62 65 20 68 61 6e 64 6c 65 64 20 62 can be handled b
127a0 65 6c 6f 77 0a 09 09 20 3b 3b 0a 09 09 20 28 6c elow... ;;... (l
127b0 65 74 20 28 28 73 6f 72 74 65 64 2d 74 65 73 74 et ((sorted-test
127c0 73 20 20 20 20 20 28 66 69 6c 74 65 72 20 0a 09 s (filter ..
127d0 09 09 09 09 20 20 76 65 63 74 6f 72 3f 0a 09 09 .... vector?...
127e0 09 09 09 20 20 28 73 6f 72 74 20 74 65 73 74 73 ... (sort tests
127f0 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 6c (lambda (a b)(l
12800 65 74 20 28 28 64 69 72 61 20 3b 3b 20 28 72 6d et ((dira ;; (rm
12810 74 3a 73 64 62 2d 71 72 79 20 27 67 65 74 73 74 t:sdb-qry 'getst
12820 72 20 0a 09 09 09 09 09 09 09 09 09 20 20 28 64 r .......... (d
12830 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
12840 72 20 61 29 29 20 3b 3b 20 29 20 20 3b 3b 20 28 r a)) ;; ) ;; (
12850 66 69 6c 65 64 62 3a 67 65 74 2d 70 61 74 68 20 filedb:get-path
12860 2a 66 64 62 2a 20 28 64 62 3a 74 65 73 74 2d 67 *fdb* (db:test-g
12870 65 74 2d 72 75 6e 64 69 72 20 61 29 29 29 0a 09 et-rundir a)))..
12880 09 09 09 09 09 09 09 09 20 28 64 69 72 62 20 3b ........ (dirb ;
12890 3b 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 27 ; (rmt:sdb-qry '
128a0 67 65 74 73 74 72 20 0a 09 09 09 09 09 09 09 09 getstr .........
128b0 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d . (db:test-get-
128c0 72 75 6e 64 69 72 20 62 29 29 29 20 3b 3b 20 29 rundir b))) ;; )
128d0 20 3b 3b 20 28 28 66 69 6c 65 64 62 3a 67 65 74 ;; ((filedb:get
128e0 2d 70 61 74 68 20 2a 66 64 62 2a 20 28 64 62 3a -path *fdb* (db:
128f0 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
12900 62 29 29 29 29 0a 09 09 09 09 09 09 09 09 20 20 b)))).........
12910 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 (if (and (str
12920 69 6e 67 3f 20 64 69 72 61 29 28 73 74 72 69 6e ing? dira)(strin
12930 67 3f 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 g? dirb)).......
12940 09 09 09 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c ... (> (string-l
12950 65 6e 67 74 68 20 64 69 72 61 29 28 73 74 72 69 ength dira)(stri
12960 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 62 29 29 ng-length dirb))
12970 0a 09 09 09 09 09 09 09 09 09 20 23 66 29 29 29 .......... #f)))
12980 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 6f )))... (to
12990 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 73 20 28 plevel-retries (
129a0 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
129b0 29 20 3b 3b 20 74 72 79 20 74 68 72 65 65 20 74 ) ;; try three t
129c0 69 6d 65 73 20 74 6f 20 6c 6f 6f 70 20 74 68 72 imes to loop thr
129d0 6f 75 67 68 20 61 6e 64 20 72 65 6d 6f 76 65 20 ough and remove
129e0 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 74 73 0a top level tests.
129f0 09 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 72 .. (test-r
12a00 65 74 72 79 2d 74 69 6d 65 20 20 28 6d 61 6b 65 etry-time (make
12a10 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 -hash-table))...
12a20 20 20 20 20 20 20 20 28 61 6c 6c 6f 77 2d 72 75 (allow-ru
12a30 6e 2d 74 69 6d 65 20 20 20 31 30 29 29 20 3b 3b n-time 10)) ;;
12a40 20 73 65 63 6f 6e 64 73 20 74 6f 20 61 6c 6c 6f seconds to allo
12a50 77 20 66 6f 72 20 6b 69 6c 6c 69 6e 67 20 74 65 w for killing te
12a60 73 74 73 20 62 65 66 6f 72 65 20 6a 75 73 74 20 sts before just
12a70 62 72 75 74 61 6c 6c 79 20 6b 69 6c 6c 69 6e 67 brutally killing
12a80 20 27 65 6d 0a 09 09 20 20 20 28 6c 65 74 20 6c 'em... (let l
12a90 6f 6f 70 20 28 28 74 65 73 74 20 28 63 61 72 20 oop ((test (car
12aa0 73 6f 72 74 65 64 2d 74 65 73 74 73 29 29 0a 09 sorted-tests))..
12ab0 09 09 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 .. (tal (c
12ac0 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 73 29 dr sorted-tests)
12ad0 29 29 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 ))... (let*
12ae0 28 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 20 ((test-id
12af0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
12b00 74 65 73 74 29 29 0a 09 09 09 20 20 20 20 28 6e test)).... (n
12b10 65 77 2d 74 65 73 74 2d 64 61 74 20 20 28 72 6d ew-test-dat (rm
12b20 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
12b30 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
12b40 74 2d 69 64 29 29 29 0a 09 09 20 20 20 20 20 20 t-id)))...
12b50 20 28 69 66 20 28 6e 6f 74 20 6e 65 77 2d 74 65 (if (not new-te
12b60 73 74 2d 64 61 74 29 0a 09 09 09 20 20 20 28 62 st-dat).... (b
12b70 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 64 65 egin.... (de
12b80 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
12b90 4f 52 3a 20 57 65 20 68 61 76 65 20 61 20 74 65 OR: We have a te
12ba0 73 74 2d 69 64 20 6f 66 20 22 20 74 65 73 74 2d st-id of " test-
12bb0 69 64 20 22 20 62 75 74 20 6e 6f 20 72 65 63 6f id " but no reco
12bc0 72 64 20 77 61 73 20 66 6f 75 6e 64 2e 20 4e 4f rd was found. NO
12bd0 54 45 3a 20 4e 6f 20 6c 6f 63 6b 69 6e 67 20 6f TE: No locking o
12be0 66 20 72 65 63 6f 72 64 73 20 69 73 20 64 6f 6e f records is don
12bf0 65 20 62 65 74 77 65 65 6e 20 70 72 6f 63 65 73 e between proces
12c00 73 65 73 2c 20 64 6f 20 6e 6f 74 20 73 69 6d 75 ses, do not simu
12c10 6c 74 61 6e 65 6f 75 73 6c 79 20 72 65 6d 6f 76 ltaneously remov
12c20 65 20 74 68 65 20 73 61 6d 65 20 72 75 6e 20 66 e the same run f
12c30 72 6f 6d 20 74 77 6f 20 70 72 6f 63 65 73 73 65 rom two processe
12c40 73 21 22 29 0a 09 09 09 20 20 20 20 20 28 69 66 s!").... (if
12c50 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
12c60 29 29 0a 09 09 09 09 20 28 6c 6f 6f 70 20 28 63 ))..... (loop (c
12c70 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
12c80 29 29 29 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 ))).... (let*
12c90 28 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 ((item-path
12ca0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
12cb0 6d 2d 70 61 74 68 20 6e 65 77 2d 74 65 73 74 2d m-path new-test-
12cc0 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 65 73 dat))..... (tes
12cd0 74 2d 6e 61 6d 65 20 20 20 20 20 28 64 62 3a 74 t-name (db:t
12ce0 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
12cf0 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 0a new-test-dat)).
12d00 09 09 09 09 20 20 28 72 75 6e 2d 64 69 72 20 20 .... (run-dir
12d10 20 20 20 20 20 3b 3b 28 66 69 6c 65 64 62 3a 67 ;;(filedb:g
12d20 65 74 2d 70 61 74 68 20 2a 66 64 62 2a 0a 09 09 et-path *fdb*...
12d30 09 09 20 20 20 3b 3b 20 28 72 6d 74 3a 73 64 62 .. ;; (rmt:sdb
12d40 2d 71 72 79 20 27 67 65 74 69 64 20 0a 09 09 09 -qry 'getid ....
12d50 09 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 . (db:test-get
12d60 2d 72 75 6e 64 69 72 20 6e 65 77 2d 74 65 73 74 -rundir new-test
12d70 2d 64 61 74 29 29 20 3b 3b 20 29 20 20 20 20 3b -dat)) ;; ) ;
12d80 3b 20 72 75 6e 20 64 69 72 20 69 73 20 66 72 6f ; run dir is fro
12d90 6d 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a m the link tree.
12da0 09 09 09 09 20 20 28 74 65 73 74 2d 73 74 61 74 .... (test-stat
12db0 65 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 e (db:test-ge
12dc0 74 2d 73 74 61 74 65 20 6e 65 77 2d 74 65 73 74 t-state new-test
12dd0 2d 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 65 -dat))..... (te
12de0 73 74 2d 66 75 6c 6c 6e 20 20 20 20 28 64 62 3a st-fulln (db:
12df0 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 6d test-get-fullnam
12e00 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 e new-test-dat))
12e10 0a 09 09 09 09 20 20 28 75 6e 61 6d 65 20 20 20 ..... (uname
12e20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
12e30 65 74 2d 75 6e 61 6d 65 20 20 20 20 6e 65 77 2d et-uname new-
12e40 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 test-dat)).....
12e50 20 28 74 6f 70 6c 65 76 65 6c 2d 77 69 74 68 2d (toplevel-with-
12e60 63 68 69 6c 64 72 65 6e 20 28 61 6e 64 20 28 64 children (and (d
12e70 62 3a 74 65 73 74 2d 67 65 74 2d 69 73 2d 74 6f b:test-get-is-to
12e80 70 6c 65 76 65 6c 20 74 65 73 74 29 0a 09 09 09 plevel test)....
12e90 09 09 09 09 20 20 20 20 20 20 20 28 3e 20 28 72 .... (> (r
12ea0 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c mt:test-toplevel
12eb0 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 -num-items run-i
12ec0 64 20 74 65 73 74 2d 6e 61 6d 65 29 20 30 29 29 d test-name) 0))
12ed0 29 29 0a 09 09 09 20 20 20 20 20 28 63 61 73 65 )).... (case
12ee0 20 61 63 74 69 6f 6e 0a 09 09 09 20 20 20 20 20 action....
12ef0 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 ((remove-runs)
12f00 0a 09 09 09 09 3b 3b 20 69 66 20 74 68 65 20 74 .....;; if the t
12f10 65 73 74 20 69 73 20 61 20 74 6f 70 6c 65 76 65 est is a topleve
12f20 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 65 6e 20 l-with-children
12f30 69 73 73 75 65 20 61 6e 20 65 72 72 6f 72 20 61 issue an error a
12f40 6e 64 20 64 6f 20 6e 6f 74 20 72 65 6d 6f 76 65 nd do not remove
12f50 0a 09 09 09 09 28 69 66 20 74 6f 70 6c 65 76 65 .....(if topleve
12f60 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 65 6e 0a l-with-children.
12f70 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 .... (begin..
12f80 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
12f90 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
12fa0 3a 20 73 6b 69 70 70 69 6e 67 20 72 65 6d 6f 76 : skipping remov
12fb0 61 6c 20 6f 66 20 22 20 74 65 73 74 2d 66 75 6c al of " test-ful
12fc0 6c 6e 20 22 20 77 69 74 68 20 72 75 6e 2d 69 64 ln " with run-id
12fd0 20 22 20 72 75 6e 2d 69 64 20 22 20 61 73 20 69 " run-id " as i
12fe0 74 20 68 61 73 20 73 75 62 20 74 65 73 74 73 22 t has sub tests"
12ff0 29 0a 09 09 09 09 20 20 20 20 20 20 28 68 61 73 )..... (has
13000 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 6f 70 h-table-set! top
13010 6c 65 76 65 6c 2d 72 65 74 72 69 65 73 20 74 65 level-retries te
13020 73 74 2d 66 75 6c 6c 6e 20 28 2b 20 28 68 61 73 st-fulln (+ (has
13030 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
13040 75 6c 74 20 74 6f 70 6c 65 76 65 6c 2d 72 65 74 ult toplevel-ret
13050 72 69 65 73 20 74 65 73 74 2d 66 75 6c 6c 6e 20 ries test-fulln
13060 30 29 20 31 29 29 0a 09 09 09 09 20 20 20 20 20 0) 1)).....
13070 20 28 69 66 20 28 3e 20 28 68 61 73 68 2d 74 61 (if (> (hash-ta
13080 62 6c 65 2d 72 65 66 20 74 6f 70 6c 65 76 65 6c ble-ref toplevel
13090 2d 72 65 74 72 69 65 73 20 74 65 73 74 2d 66 75 -retries test-fu
130a0 6c 6c 6e 29 20 33 29 0a 09 09 09 09 09 20 20 28 lln) 3)...... (
130b0 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
130c0 61 6c 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 al))......
130d0 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
130e0 63 64 72 20 74 61 6c 29 29 29 20 3b 3b 20 6e 6f cdr tal))) ;; no
130f0 20 65 6c 73 65 20 63 6c 61 75 73 65 20 2d 20 64 else clause - d
13100 72 6f 70 20 69 74 20 69 66 20 6e 6f 20 6d 6f 72 rop it if no mor
13110 65 20 69 6e 20 71 75 65 75 65 20 61 6e 64 20 3e e in queue and >
13120 20 33 20 74 72 69 65 73 0a 09 09 09 09 09 20 20 3 tries......
13130 28 6c 65 74 20 28 28 6e 65 77 74 61 6c 20 28 61 (let ((newtal (a
13140 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 20 ppend tal (list
13150 74 65 73 74 29 29 29 29 0a 09 09 09 09 09 20 20 test))))......
13160 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
13170 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
13180 29 29 29 29 20 3b 3b 20 6c 6f 6f 70 20 77 69 74 )))) ;; loop wit
13190 68 20 74 65 73 74 20 73 74 69 6c 6c 20 69 6e 20 h test still in
131a0 71 75 65 75 65 0a 09 09 09 09 20 20 20 20 28 62 queue..... (b
131b0 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 egin..... (
131c0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
131d0 20 30 20 22 74 65 73 74 3a 20 22 20 74 65 73 74 0 "test: " test
131e0 2d 6e 61 6d 65 20 22 20 69 74 65 73 74 2d 73 74 -name " itest-st
131f0 61 74 65 3a 20 22 20 74 65 73 74 2d 73 74 61 74 ate: " test-stat
13200 65 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 e)..... (if
13210 20 28 6d 65 6d 62 65 72 20 74 65 73 74 2d 73 74 (member test-st
13220 61 74 65 20 28 6c 69 73 74 20 22 52 55 4e 4e 49 ate (list "RUNNI
13230 4e 47 22 20 22 4c 41 55 4e 43 48 45 44 22 20 22 NG" "LAUNCHED" "
13240 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 REMOTEHOSTSTART"
13250 20 22 4b 49 4c 4c 52 45 51 22 29 29 0a 09 09 09 "KILLREQ"))....
13260 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 .. (begin......
13270 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
13280 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
13290 61 75 6c 74 20 74 65 73 74 2d 72 65 74 72 79 2d ault test-retry-
132a0 74 69 6d 65 20 74 65 73 74 2d 66 75 6c 6c 6e 20 time test-fulln
132b0 23 66 29 29 0a 09 09 09 09 09 09 28 62 65 67 69 #f)).......(begi
132c0 6e 0a 09 09 09 09 09 09 20 20 3b 3b 20 77 61 6e n....... ;; wan
132d0 74 20 74 6f 20 73 65 74 20 74 6f 20 52 45 4d 4f t to set to REMO
132e0 56 49 4e 47 20 42 55 54 20 43 41 4e 4e 4f 54 20 VING BUT CANNOT
132f0 64 6f 20 69 74 20 68 65 72 65 3f 0a 09 09 09 09 do it here?.....
13300 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
13310 73 65 74 21 20 74 65 73 74 2d 72 65 74 72 79 2d set! test-retry-
13320 74 69 6d 65 20 74 65 73 74 2d 66 75 6c 6c 6e 20 time test-fulln
13330 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
13340 29 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 69 ))))...... (i
13350 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 f (> (- (current
13360 2d 73 65 63 6f 6e 64 73 29 28 68 61 73 68 2d 74 -seconds)(hash-t
13370 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
13380 74 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 try-time test-fu
13390 6c 6c 6e 29 29 20 61 6c 6c 6f 77 2d 72 75 6e 2d lln)) allow-run-
133a0 74 69 6d 65 29 0a 09 09 09 09 09 09 3b 3b 20 54 time).......;; T
133b0 68 69 73 20 74 65 73 74 20 69 73 20 6e 6f 74 20 his test is not
133c0 69 6e 20 61 20 63 6f 72 72 65 63 74 20 73 74 61 in a correct sta
133d0 74 65 20 66 6f 72 20 63 6c 65 61 6e 69 6e 67 20 te for cleaning
133e0 75 70 2e 20 4c 65 74 27 73 20 74 72 79 20 73 6f up. Let's try so
133f0 6d 65 20 67 72 61 63 65 66 75 6c 20 73 68 75 74 me graceful shut
13400 64 6f 77 6e 20 73 74 65 70 73 20 66 69 72 73 74 down steps first
13410 0a 09 09 09 09 09 09 3b 3b 20 53 65 74 20 74 68 .......;; Set th
13420 65 20 74 65 73 74 20 74 6f 20 22 4b 49 4c 4c 52 e test to "KILLR
13430 45 51 22 20 61 6e 64 20 77 61 69 74 20 66 69 76 EQ" and wait fiv
13440 65 20 73 65 63 6f 6e 64 73 20 74 68 65 6e 20 74 e seconds then t
13450 72 79 20 61 67 61 69 6e 2e 20 52 65 70 65 61 74 ry again. Repeat
13460 20 75 70 20 74 6f 20 66 69 76 65 20 74 69 6d 65 up to five time
13470 73 20 74 68 65 6e 20 67 69 76 65 0a 09 09 09 09 s then give.....
13480 09 09 3b 3b 20 75 70 20 61 6e 64 20 62 6c 6f 77 ..;; up and blow
13490 20 69 74 20 61 77 61 79 2e 0a 09 09 09 09 09 09 it away........
134a0 28 62 65 67 69 6e 0a 09 09 09 09 09 09 20 20 28 (begin....... (
134b0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
134c0 41 52 4e 49 4e 47 3a 20 63 6f 75 6c 64 20 6e 6f ARNING: could no
134d0 74 20 67 72 61 63 65 66 75 6c 6c 79 20 72 65 6d t gracefully rem
134e0 6f 76 65 20 74 65 73 74 20 22 20 74 65 73 74 2d ove test " test-
134f0 66 75 6c 6c 6e 20 22 2c 20 74 72 69 65 64 20 74 fulln ", tried t
13500 6f 20 6b 69 6c 6c 20 69 74 20 74 6f 20 6e 6f 20 o kill it to no
13510 61 76 61 69 6c 2e 20 46 6f 72 63 69 6e 67 20 73 avail. Forcing s
13520 74 61 74 65 20 74 6f 20 46 41 49 4c 45 44 4b 49 tate to FAILEDKI
13530 4c 4c 20 61 6e 64 20 63 6f 6e 74 69 6e 75 69 6e LL and continuin
13540 67 22 29 0a 09 09 09 09 09 20 20 20 20 28 6d 74 g")...... (mt
13550 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
13560 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
13570 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
13580 2d 69 64 20 74 65 73 74 29 20 22 46 41 49 4c 45 -id test) "FAILE
13590 44 4b 49 4c 4c 22 20 22 6e 2f 61 22 20 23 66 29 DKILL" "n/a" #f)
135a0 0a 09 09 09 09 09 09 20 20 28 74 68 72 65 61 64 ....... (thread
135b0 2d 73 6c 65 65 70 21 20 31 29 29 0a 09 09 09 09 -sleep! 1)).....
135c0 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 ..(begin......
135d0 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (mt:test-set-s
135e0 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
135f0 64 20 72 75 6e 2d 69 64 20 28 64 62 3a 74 65 73 d run-id (db:tes
13600 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
13610 4b 49 4c 4c 52 45 51 22 20 22 6e 2f 61 22 20 23 KILLREQ" "n/a" #
13620 66 29 0a 09 09 09 09 09 09 20 20 28 74 68 72 65 f)....... (thre
13630 61 64 2d 73 6c 65 65 70 21 20 31 29 29 29 0a 09 ad-sleep! 1)))..
13640 09 09 09 09 20 20 20 20 3b 3b 20 4e 4f 54 45 3a .... ;; NOTE:
13650 20 54 68 69 73 20 69 73 20 73 75 62 6f 70 74 69 This is subopti
13660 6d 61 6c 20 61 73 20 74 68 65 20 74 65 73 74 64 mal as the testd
13670 61 74 61 20 77 69 6c 6c 20 62 65 20 75 73 65 64 ata will be used
13680 20 6c 61 74 65 72 20 61 6e 64 20 74 68 65 20 73 later and the s
13690 74 61 74 65 2f 73 74 61 74 75 73 20 6d 61 79 20 tate/status may
136a0 68 61 76 65 20 63 68 61 6e 67 65 64 20 2e 2e 2e have changed ...
136b0 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 28 6e ...... (if (n
136c0 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 09 09 ull? tal).......
136d0 28 6c 6f 6f 70 20 6e 65 77 2d 74 65 73 74 2d 64 (loop new-test-d
136e0 61 74 20 74 61 6c 29 0a 09 09 09 09 09 09 28 6c at tal).......(l
136f0 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 61 70 oop (car tal)(ap
13700 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 20 6e pend tal (list n
13710 65 77 2d 74 65 73 74 2d 64 61 74 29 29 29 29 29 ew-test-dat)))))
13720 0a 09 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 ...... (begin..
13730 09 09 09 09 20 20 20 20 28 72 75 6e 73 3a 72 65 .... (runs:re
13740 6d 6f 76 65 2d 74 65 73 74 2d 64 69 72 65 63 74 move-test-direct
13750 6f 72 79 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 ory new-test-dat
13760 20 6d 6f 64 65 29 20 3b 3b 20 27 72 65 6d 6f 76 mode) ;; 'remov
13770 65 2d 61 6c 6c 29 0a 09 09 09 09 09 20 20 20 20 e-all)......
13780 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
13790 74 61 6c 29 29 0a 09 09 09 09 09 09 28 6c 6f 6f tal)).......(loo
137a0 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
137b0 74 61 6c 29 29 29 29 29 29 29 29 0a 09 09 09 20 tal))))))))....
137c0 20 20 20 20 20 20 28 28 73 65 74 2d 73 74 61 74 ((set-stat
137d0 65 2d 73 74 61 74 75 73 29 0a 09 09 09 09 28 64 e-status).....(d
137e0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
137f0 32 20 22 6e 65 77 20 73 74 61 74 65 20 22 20 28 2 "new state " (
13800 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 car state-status
13810 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 73 20 ) ", new status
13820 22 20 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 " (cadr state-st
13830 61 74 75 73 29 29 0a 09 09 09 09 28 6d 74 3a 74 atus)).....(mt:t
13840 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
13850 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 atus-by-id run-i
13860 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 d (db:test-get-i
13870 64 20 74 65 73 74 29 20 28 63 61 72 20 73 74 61 d test) (car sta
13880 74 65 2d 73 74 61 74 75 73 29 28 63 61 64 72 20 te-status)(cadr
13890 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 23 66 state-status) #f
138a0 29 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 20 28 ).....(if (not (
138b0 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 null? tal)).....
138c0 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
138d0 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a al)(cdr tal)))).
138e0 09 09 09 20 20 20 20 20 20 20 28 28 72 75 6e 2d ... ((run-
138f0 77 61 69 74 29 0a 09 09 09 09 28 64 65 62 75 67 wait).....(debug
13900 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 73 :print-info 2 "s
13910 74 69 6c 6c 20 77 61 69 74 69 6e 67 2c 20 22 20 till waiting, "
13920 28 6c 65 6e 67 74 68 20 74 65 73 74 73 29 20 22 (length tests) "
13930 20 74 65 73 74 73 20 73 74 69 6c 6c 20 72 75 6e tests still run
13940 6e 69 6e 67 22 29 0a 09 09 09 09 28 74 68 72 65 ning").....(thre
13950 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 09 09 ad-sleep! 10)...
13960 09 09 28 6c 65 74 20 28 28 6e 65 77 2d 74 65 73 ..(let ((new-tes
13970 74 73 20 28 70 72 6f 63 2d 67 65 74 2d 74 65 73 ts (proc-get-tes
13980 74 73 20 72 75 6e 2d 69 64 29 29 29 0a 09 09 09 ts run-id)))....
13990 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 . (if (null? ne
139a0 77 2d 74 65 73 74 73 29 0a 09 09 09 09 20 20 20 w-tests).....
139b0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
139c0 69 6e 66 6f 20 31 20 22 52 75 6e 20 63 6f 6d 70 info 1 "Run comp
139d0 6c 65 74 65 64 20 61 63 63 6f 72 64 69 6e 67 20 leted according
139e0 74 6f 20 7a 65 72 6f 20 74 65 73 74 73 20 6d 61 to zero tests ma
139f0 74 63 68 69 6e 67 20 70 72 6f 76 69 64 65 64 20 tching provided
13a00 63 72 69 74 65 72 69 61 2e 22 29 0a 09 09 09 09 criteria.").....
13a10 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
13a20 20 6e 65 77 2d 74 65 73 74 73 29 28 63 64 72 20 new-tests)(cdr
13a30 6e 65 77 2d 74 65 73 74 73 29 29 29 29 29 0a 09 new-tests)))))..
13a40 09 09 20 20 20 20 20 20 20 28 28 61 72 63 68 69 .. ((archi
13a50 76 65 29 0a 09 09 09 09 28 69 66 20 28 61 6e 64 ve).....(if (and
13a60 20 72 75 6e 2d 64 69 72 20 28 6e 6f 74 20 74 6f run-dir (not to
13a70 70 6c 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c plevel-with-chil
13a80 64 72 65 6e 29 29 0a 09 09 09 09 20 20 20 20 28 dren))..... (
13a90 6c 65 74 20 28 28 64 64 69 72 20 28 63 6f 6e 63 let ((ddir (conc
13aa0 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 29 0a run-dir "/"))).
13ab0 09 09 09 09 20 20 20 20 20 20 28 63 61 73 65 20 .... (case
13ac0 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
13ad0 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
13ae0 61 72 63 68 69 76 65 22 29 29 0a 09 09 09 09 09 archive"))......
13af0 28 28 73 61 76 65 20 73 61 76 65 2d 72 65 6d 6f ((save save-remo
13b00 76 65 20 6b 65 65 70 2d 68 74 6d 6c 29 0a 09 09 ve keep-html)...
13b10 09 09 09 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ... (if (file-ex
13b20 69 73 74 73 3f 20 64 64 69 72 29 0a 09 09 09 09 ists? ddir).....
13b30 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
13b40 6e 74 2d 69 6e 66 6f 20 30 20 22 45 73 74 69 6d nt-info 0 "Estim
13b50 61 74 69 6e 67 20 64 69 73 6b 20 73 70 61 63 65 ating disk space
13b60 20 75 73 61 67 65 20 66 6f 72 20 22 20 74 65 73 usage for " tes
13b70 74 2d 66 75 6c 6c 6e 20 22 3a 20 22 20 28 63 6f t-fulln ": " (co
13b80 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d 73 70 mmon:get-disk-sp
13b90 61 63 65 2d 75 73 65 64 20 64 64 69 72 29 29 29 ace-used ddir)))
13ba0 29 29 29 29 0a 09 09 09 09 28 69 66 20 28 6e 6f )))).....(if (no
13bb0 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
13bc0 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
13bd0 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
13be0 29 29 0a 09 09 09 20 20 20 20 20 20 20 29 29 29 )).... )))
13bf0 0a 09 09 20 20 20 20 20 20 20 29 0a 09 09 20 20 ... )...
13c00 20 20 20 28 69 66 20 77 6f 72 6b 65 72 2d 74 68 (if worker-th
13c10 72 65 61 64 20 28 74 68 72 65 61 64 2d 6a 6f 69 read (thread-joi
13c20 6e 21 20 77 6f 72 6b 65 72 2d 74 68 72 65 61 64 n! worker-thread
13c30 29 29 29 29 29 29 0a 09 20 20 20 3b 3b 20 72 65 )))))).. ;; re
13c40 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 20 move the run if
13c50 7a 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 69 zero tests remai
13c60 6e 0a 09 20 20 20 28 69 66 20 28 65 71 3f 20 61 n.. (if (eq? a
13c70 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 ction 'remove-ru
13c80 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 ns).. (let
13c90 20 28 28 72 65 6d 74 65 73 74 73 20 28 6d 74 3a ((remtests (mt:
13ca0 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
13cb0 6e 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d n (db:get-value-
13cc0 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
13cd0 61 64 65 72 20 22 69 64 22 29 20 23 66 20 27 28 ader "id") #f '(
13ce0 22 44 45 4c 45 54 45 44 22 29 20 27 28 22 6e 2f "DELETED") '("n/
13cf0 61 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 a") not-in: #t))
13d00 29 0a 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 )... (if (null?
13d10 72 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 remtests) ;; no
13d20 6d 6f 72 65 20 74 65 73 74 73 20 72 65 6d 61 69 more tests remai
13d30 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 6c 65 74 ning... (let
13d40 2a 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 * ((dparts (str
13d50 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 74 70 ing-split lasttp
13d60 61 74 68 20 22 2f 22 29 29 0a 09 09 09 20 20 20 ath "/"))....
13d70 20 28 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 (runpath (conc
13d80 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 "/" (string-inte
13d90 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 28 rsperse .......(
13da0 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 take dparts (- (
13db0 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 31 length dparts) 1
13dc0 29 29 0a 09 09 09 09 09 09 22 2f 22 29 29 29 29 ))......."/"))))
13dd0 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
13de0 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
13df0 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 ng run: " runkey
13e00 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
13e10 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
13e20 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
13e30 22 29 20 22 20 61 6e 64 20 72 65 6c 61 74 65 64 ") " and related
13e40 20 72 65 63 6f 72 64 22 29 0a 09 09 20 20 20 20 record")...
13e50 20 20 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d 72 (rmt:delete-r
13e60 75 6e 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 un run-id)...
13e70 20 20 20 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d (rmt:delete-
13e80 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
13e90 2d 72 65 63 6f 72 64 73 29 0a 09 09 20 20 20 20 -records)...
13ea0 20 20 20 3b 3b 20 28 72 6d 74 3a 73 65 74 2d 76 ;; (rmt:set-v
13eb0 61 72 20 22 44 45 4c 45 54 45 44 5f 54 45 53 54 ar "DELETED_TEST
13ec0 53 22 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f S" (current-seco
13ed0 6e 64 73 29 29 0a 09 09 20 20 20 20 20 20 20 3b nds))... ;
13ee0 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 75 72 65 ; need to figure
13ef0 20 6f 75 74 20 74 68 65 20 70 61 74 68 20 74 6f out the path to
13f00 20 74 68 65 20 72 75 6e 20 64 69 72 20 61 6e 64 the run dir and
13f10 20 72 65 6d 6f 76 65 20 69 74 20 69 66 20 65 6d remove it if em
13f20 70 74 79 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 pty... ;;
13f30 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 (if (null? (g
13f40 6c 6f 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 lob (conc runpat
13f50 68 20 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 h "/*")))...
13f60 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 62 65 ;; (be
13f70 67 69 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 gin... ;;
13f80 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 . (debug:print 1
13f90 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 "Removing run d
13fa0 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 ir " runpath)...
13fb0 20 20 20 20 20 20 20 3b 3b 20 09 20 28 73 79 73 ;; . (sys
13fc0 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 tem (conc "rmdir
13fd0 20 2d 70 20 22 20 72 75 6e 70 61 74 68 29 29 29 -p " runpath)))
13fe0 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 29 29 )... )))))
13ff0 0a 09 20 29 29 0a 20 20 20 20 20 72 75 6e 73 29 .. )). runs)
14000 0a 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 . ;; (sqlite3
14010 3a 66 69 6e 61 6c 69 7a 65 21 20 28 64 62 3a 64 :finalize! (db:d
14020 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 elay-if-busy tdb
14030 64 61 74 29 29 0a 20 20 20 20 29 0a 20 20 23 74 dat)). ). #t
14040 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
14050 3a 72 65 6d 6f 76 65 2d 74 65 73 74 2d 64 69 72 :remove-test-dir
14060 65 63 74 6f 72 79 20 74 65 73 74 20 6d 6f 64 65 ectory test mode
14070 29 20 3b 3b 20 72 65 6d 6f 76 65 2d 64 61 74 61 ) ;; remove-data
14080 2d 6f 6e 6c 79 29 0a 20 20 28 6c 65 74 2a 20 28 -only). (let* (
14090 28 72 75 6e 2d 64 69 72 20 20 20 20 20 20 20 28 (run-dir (
140a0 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
140b0 69 72 20 74 65 73 74 29 29 20 20 20 20 3b 3b 20 ir test)) ;;
140c0 72 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 run dir is from
140d0 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 20 the link tree..
140e0 28 72 65 61 6c 2d 64 69 72 20 20 20 20 20 20 28 (real-dir (
140f0 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
14100 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 run-dir)....
14110 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 (resolve-pathna
14120 6d 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 me run-dir)....
14130 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 63 61 #f))). (ca
14140 73 65 20 6d 6f 64 65 0a 20 20 20 20 20 20 28 28 se mode. ((
14150 72 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 remove-data-only
14160 29 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 )(mt:test-set-st
14170 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
14180 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
14190 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 n_id test)(db:te
141a0 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
141b0 22 43 4c 45 41 4e 49 4e 47 22 20 22 4c 4f 43 4b "CLEANING" "LOCK
141c0 45 44 22 20 23 66 29 29 0a 20 20 20 20 20 20 28 ED" #f)). (
141d0 28 72 65 6d 6f 76 65 2d 61 6c 6c 29 20 20 20 20 (remove-all)
141e0 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (mt:test-set-s
141f0 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
14200 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 d (db:test-get-r
14210 75 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 un_id test)(db:t
14220 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
14230 20 22 52 45 4d 4f 56 49 4e 47 22 20 22 4c 4f 43 "REMOVING" "LOC
14240 4b 45 44 22 20 23 66 29 29 0a 20 20 20 20 20 20 KED" #f)).
14250 28 28 61 72 63 68 69 76 65 2d 72 65 6d 6f 76 65 ((archive-remove
14260 29 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d ) (mt:test-set-
14270 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
14280 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d id (db:test-get-
14290 72 75 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a run_id test)(db:
142a0 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
142b0 29 20 22 41 52 43 48 49 56 45 5f 52 45 4d 4f 56 ) "ARCHIVE_REMOV
142c0 49 4e 47 22 20 23 66 20 23 66 29 29 29 0a 20 20 ING" #f #f))).
142d0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
142e0 6e 66 6f 20 31 20 22 41 74 74 65 6d 70 74 69 6e nfo 1 "Attemptin
142f0 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 28 69 g to remove " (i
14300 66 20 72 65 61 6c 2d 64 69 72 20 28 63 6f 6e 63 f real-dir (conc
14310 20 22 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 " dir " real-di
14320 72 20 22 20 61 6e 64 20 22 29 20 22 22 29 20 22 r " and ") "") "
14330 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 link " run-dir)
14340 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 65 . (if (and re
14350 61 6c 2d 64 69 72 20 0a 09 20 20 20 20 20 28 3e al-dir .. (>
14360 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
14370 72 65 61 6c 2d 64 69 72 29 20 35 29 0a 09 20 20 real-dir) 5)..
14380 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f (file-exists?
14390 20 72 65 61 6c 2d 64 69 72 29 29 20 3b 3b 20 62 real-dir)) ;; b
143a0 61 64 20 68 65 75 72 69 73 74 69 63 20 62 75 74 ad heuristic but
143b0 20 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 should prevent
143c0 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a /tmp /home etc..
143d0 09 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 .(begin ;; let*
143e0 28 28 72 65 61 6c 70 61 74 68 20 28 72 65 73 6f ((realpath (reso
143f0 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e lve-pathname run
14400 2d 64 69 72 29 29 29 0a 09 20 20 28 64 65 62 75 -dir))).. (debu
14410 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
14420 52 65 63 75 72 73 69 76 65 6c 79 20 72 65 6d 6f Recursively remo
14430 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 29 ving " real-dir)
14440 0a 09 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 .. (if (file-ex
14450 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 0a ists? real-dir).
14460 09 20 20 20 20 20 20 28 72 75 6e 73 3a 73 61 66 . (runs:saf
14470 65 2d 64 65 6c 65 74 65 2d 74 65 73 74 2d 64 69 e-delete-test-di
14480 72 20 72 65 61 6c 2d 64 69 72 29 0a 09 20 20 20 r real-dir)..
14490 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
144a0 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 0 "WARNING: test
144b0 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 dir " real-dir
144c0 22 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 " appears to not
144d0 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 exist or is not
144e0 20 72 65 61 64 61 62 6c 65 22 29 29 29 0a 09 28 readable")))..(
144f0 69 66 20 72 65 61 6c 2d 64 69 72 20 0a 09 20 20 if real-dir ..
14500 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
14510 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 63 "WARNING: direc
14520 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 72 20 tory " real-dir
14530 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 " does not exist
14540 22 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 ").. (debug:p
14550 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
14560 20 6e 6f 20 72 65 61 6c 20 64 69 72 65 63 74 6f no real directo
14570 72 79 20 63 6f 72 72 6f 73 70 6f 6e 64 69 6e 67 ry corrosponding
14580 20 74 6f 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 to link " run-d
14590 69 72 20 22 2c 20 6e 6f 74 68 69 6e 67 20 64 6f ir ", nothing do
145a0 6e 65 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 ne"))). (if (
145b0 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 symbolic-link? r
145c0 75 6e 2d 64 69 72 29 0a 09 28 62 65 67 69 6e 0a un-dir)..(begin.
145d0 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
145e0 69 6e 66 6f 20 31 20 22 52 65 6d 6f 76 69 6e 67 info 1 "Removing
145f0 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 symlink " run-d
14600 69 72 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 ir).. (handle-e
14610 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 xceptions.. ex
14620 6e 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 n.. (debug:pri
14630 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 nt 0 "ERROR: Fa
14640 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 iled to remove s
14650 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 ymlink " run-dir
14660 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
14670 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
14680 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
14690 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 n) ", attempting
146a0 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 to continue")..
146b0 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 (delete-file
146c0 72 75 6e 2d 64 69 72 29 29 29 0a 09 28 69 66 20 run-dir)))..(if
146d0 28 64 69 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d (directory? run-
146e0 64 69 72 29 0a 09 20 20 20 20 28 69 66 20 28 3e dir).. (if (>
146f0 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 (directory-fold
14700 20 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b (lambda (f x)(+
14710 20 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 1 x)) 0 run-dir
14720 29 20 30 29 0a 09 09 28 64 65 62 75 67 3a 70 72 ) 0)...(debug:pr
14730 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
14740 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f refusing to remo
14750 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 ve " run-dir " a
14760 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 s it is not empt
14770 79 22 29 0a 09 09 28 68 61 6e 64 6c 65 2d 65 78 y")...(handle-ex
14780 63 65 70 74 69 6f 6e 73 0a 09 09 20 65 78 6e 0a ceptions... exn.
14790 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
147a0 30 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 0 "ERROR: Faile
147b0 64 20 74 6f 20 72 65 6d 6f 76 65 20 64 69 72 65 d to remove dire
147c0 63 74 6f 72 79 20 22 20 72 75 6e 2d 64 69 72 20 ctory " run-dir
147d0 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
147e0 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
147f0 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
14800 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 ) ", attempting
14810 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 to continue")...
14820 20 28 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f (delete-directo
14830 72 79 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 20 ry run-dir)))..
14840 20 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e 2d (if (and run-
14850 64 69 72 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 dir... (not
14860 28 6d 65 6d 62 65 72 20 72 75 6e 2d 64 69 72 20 (member run-dir
14870 28 6c 69 73 74 20 22 6e 2f 61 22 20 22 2f 74 6d (list "n/a" "/tm
14880 70 2f 62 61 64 6e 61 6d 65 22 29 29 29 29 0a 09 p/badname"))))..
14890 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
148a0 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 72 65 "WARNING: not re
148b0 6d 6f 76 69 6e 67 20 22 20 72 75 6e 2d 64 69 72 moving " run-dir
148c0 20 22 20 61 73 20 69 74 20 65 69 74 68 65 72 20 " as it either
148d0 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 6f 72 doesn't exist or
148e0 20 69 73 20 6e 6f 74 20 61 20 73 79 6d 6c 69 6e is not a symlin
148f0 6b 22 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 k")...(debug:pri
14900 6e 74 20 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 nt 0 "NOTE: the
14910 72 75 6e 20 64 69 72 20 66 6f 72 20 74 68 69 73 run dir for this
14920 20 74 65 73 74 20 69 73 20 75 6e 64 65 66 69 6e test is undefin
14930 65 64 2e 20 54 65 73 74 20 6d 61 79 20 68 61 76 ed. Test may hav
14940 65 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 64 e already been d
14950 65 6c 65 74 65 64 2e 22 29 29 0a 09 20 20 20 20 eleted."))..
14960 29 29 0a 20 20 20 20 3b 3b 20 4f 6e 6c 79 20 64 )). ;; Only d
14970 65 6c 65 74 65 20 74 68 65 20 72 65 63 6f 72 64 elete the record
14980 73 20 2a 61 66 74 65 72 2a 20 72 65 6d 6f 76 69 s *after* removi
14990 6e 67 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 ng the directory
149a0 2e 20 49 66 20 74 68 69 6e 67 73 20 66 61 69 6c . If things fail
149b0 20 77 65 20 68 61 76 65 20 61 20 72 65 63 6f 72 we have a recor
149c0 64 20 0a 20 20 20 20 28 63 61 73 65 20 6d 6f 64 d . (case mod
149d0 65 0a 20 20 20 20 20 20 28 28 72 65 6d 6f 76 65 e. ((remove
149e0 2d 64 61 74 61 2d 6f 6e 6c 79 29 28 6d 74 3a 74 -data-only)(mt:t
149f0 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
14a00 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 atus-by-id (db:t
14a10 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 est-get-run_id t
14a20 65 73 74 29 28 64 62 3a 74 65 73 74 2d 67 65 74 est)(db:test-get
14a30 2d 69 64 20 74 65 73 74 29 20 22 4e 4f 54 5f 53 -id test) "NOT_S
14a40 54 41 52 54 45 44 22 20 22 6e 2f 61 22 20 23 66 TARTED" "n/a" #f
14a50 29 29 0a 20 20 20 20 20 20 28 28 61 72 63 68 69 )). ((archi
14a60 76 65 2d 72 65 6d 6f 76 65 29 20 20 28 6d 74 3a ve-remove) (mt:
14a70 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
14a80 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a tatus-by-id (db:
14a90 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 test-get-run_id
14aa0 74 65 73 74 29 28 64 62 3a 74 65 73 74 2d 67 65 test)(db:test-ge
14ab0 74 2d 69 64 20 74 65 73 74 29 20 22 41 52 43 48 t-id test) "ARCH
14ac0 49 56 45 44 22 20 23 66 20 23 66 29 29 0a 20 20 IVED" #f #f)).
14ad0 20 20 20 20 28 65 6c 73 65 20 28 72 6d 74 3a 64 (else (rmt:d
14ae0 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 elete-test-recor
14af0 64 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d ds (db:test-get-
14b00 72 75 6e 5f 69 64 20 74 65 73 74 29 20 28 64 62 run_id test) (db
14b10 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
14b20 74 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d t))))))..;;=====
14b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b70 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f =.;; Routines fo
14b80 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 r manipulating r
14b90 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
14ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14bc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14bd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
14be0 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c Since many call
14bf0 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 69 s to a run requi
14c00 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 20 74 re pretty much t
14c10 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 0a 3b he same setup .;
14c20 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 20 69 ; this wrapper i
14c30 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 63 65 s used to reduce
14c40 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 6f 6e the replication
14c50 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 of code.(define
14c60 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 (general-run-ca
14c70 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 61 63 ll switchname ac
14c80 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a tion-desc proc).
14c90 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 (let ((runname
14ca0 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
14cb0 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 28 61 rg "-runname")(a
14cc0 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
14cd0 6e 6e 61 6d 65 22 29 29 29 0a 09 28 74 61 72 67 nname")))..(targ
14ce0 65 74 20 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 et (common:args
14cf0 2d 67 65 74 2d 74 61 72 67 65 74 29 29 29 0a 20 -get-target))).
14d00 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
14d10 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 not target).
14d20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
14d30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 "ERROR: Missing
14d40 20 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 required parame
14d50 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 ter for " switch
14d60 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 name ", you must
14d70 20 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 specify the tar
14d80 67 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 get with -target
14d90 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 "). (exit 3
14da0 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 )). ((not ru
14db0 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 nname). (de
14dc0 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
14dd0 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
14de0 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
14df0 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
14e00 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
14e10 69 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 ify the run name
14e20 20 77 69 74 68 20 2d 72 75 6e 6e 61 6d 65 20 72 with -runname r
14e30 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 unname"). (
14e40 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 exit 3)). (e
14e50 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 lse. (let (
14e60 3b 3b 20 28 64 62 20 20 20 23 66 29 0a 09 20 20 ;; (db #f)..
14e70 20 20 28 6b 65 79 73 20 23 66 29 29 0a 09 28 69 (keys #f))..(i
14e80 66 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d f (launch:setup-
14e90 66 6f 72 2d 72 75 6e 29 0a 09 20 20 20 20 28 6c for-run).. (l
14ea0 61 75 6e 63 68 3a 63 61 63 68 65 2d 63 6f 6e 66 aunch:cache-conf
14eb0 69 67 29 0a 09 20 20 20 20 28 62 65 67 69 6e 20 ig).. (begin
14ec0 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
14ed0 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 20 74 rint 0 "Failed t
14ee0 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e 67 o setup, exiting
14ef0 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
14f00 31 29 29 29 0a 09 28 73 65 74 21 20 6b 65 79 73 1)))..(set! keys
14f10 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 (keys:config-ge
14f20 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 t-fields *config
14f30 64 61 74 2a 29 29 0a 09 3b 3b 20 68 61 76 65 20 dat*))..;; have
14f40 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 enough to proces
14f50 73 20 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 s -target or -re
14f60 71 74 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 qtarg here..(if
14f70 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
14f80 72 65 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 reqtarg").. (
14f90 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 let* ((runconfig
14fa0 66 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 f (conc *toppat
14fb0 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
14fc0 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 config")) ;; DO
14fd0 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c NOT EVALUATE ALL
14fe0 20 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 ... (runconfi
14ff0 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 g (read-config
15000 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 74 runconfigf #f #t
15010 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 environ-patt: #
15020 66 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 f))).. (if
15030 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
15040 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 default runconfi
15050 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 g (args:get-arg
15060 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 0a "-reqtarg") #f).
15070 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 .. (keys:target
15080 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 -set-args keys (
15090 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
150a0 65 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 eqtarg") args:ar
150b0 67 2d 68 61 73 68 29 0a 09 09 20 20 20 20 0a 09 g-hash)... ..
150c0 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
150d0 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
150e0 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a ERROR: [" (args:
150f0 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
15100 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 g") "] not found
15110 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 in " runconfigf
15120 29 0a 09 09 20 20 20 20 3b 3b 20 28 69 66 20 64 )... ;; (if d
15130 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c b (sqlite3:final
15140 69 7a 65 21 20 64 62 29 29 0a 09 09 20 20 20 20 ize! db))...
15150 28 65 78 69 74 20 31 29 0a 09 09 20 20 20 20 29 (exit 1)... )
15160 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 )).. (if (arg
15170 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
15180 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 et")...(keys:tar
15190 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 get-set-args key
151a0 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 s (args:get-arg
151b0 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 "-target" args:a
151c0 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 rg-hash) args:ar
151d0 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 g-hash)))..(if (
151e0 6e 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 not (car *config
151f0 69 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 info*)).. (be
15200 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
15210 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
15220 3a 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 : Attempted to "
15230 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 action-desc " b
15240 75 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 ut run area conf
15250 69 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e ig file not foun
15260 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 d").. (exit
15270 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 1)).. ;; Ext
15280 72 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e ract out stuff n
15290 65 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 eeded in most or
152a0 20 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 many calls..
152b0 20 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 ;; here then ca
152c0 6c 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 ll proc.. (le
152d0 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 t* ((keyvals
152e0 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 (keys:target->ke
152f0 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 yval keys target
15300 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 ))).. (proc
15310 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
15320 6b 65 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a keys keyvals))).
15330 09 3b 3b 20 28 69 66 20 64 62 20 28 73 71 6c 69 .;; (if db (sqli
15340 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
15350 29 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f ))..(set! *didso
15360 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 mething* #t)))))
15370 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
15380 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15390 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
153a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
153b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c ===========.;; L
153c0 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a ock/unlock runs.
153d0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
153e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
153f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15400 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15410 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
15420 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c e (runs:handle-l
15430 6f 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b 65 ocking target ke
15440 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 ys runname lock
15450 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 unlock user). (
15460 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 let* ((db
15470 23 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 #f).. (rundat
15480 28 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d (mt:get-runs-by-
15490 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d patt keys runnam
154a0 65 20 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 e target)).. (he
154b0 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 ader (vector-r
154c0 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 ef rundat 0))..
154d0 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f (runs (vecto
154e0 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
154f0 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
15500 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
15510 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 (let ((run-id (d
15520 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
15530 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
15540 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 "id")))... (if
15550 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 (or lock.... (
15560 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 and unlock....
15570 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
15580 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 (print "Do you
15590 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 really wish to u
155a0 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d nlock run " run-
155b0 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 id "?\n y/n: "
155c0 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 )..... (equal? "
155d0 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 y" (read-line)))
155e0 29 29 0a 09 09 20 20 20 20 20 20 28 72 6d 74 3a ))... (rmt:
155f0 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 lock/unlock-run
15600 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
15610 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 ck user)...
15620 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
15630 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 6c fo 0 "Skipping l
15640 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 ock/unlock on "
15650 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 20 run-id))))..
15660 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d runs))).;;====
15670 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15680 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15690 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
156a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
156b0 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e ==.;; Rollup run
156c0 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
156d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
156e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
156f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15700 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 ==========..;; U
15710 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f 6d pdate the test_m
15720 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 68 eta table for th
15730 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 is test.(define
15740 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
15750 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 t_meta test-name
15760 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c test-conf). (l
15770 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 et ((currrecord
15780 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 (rmt:testmeta-ge
15790 74 2d 72 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 t-record test-na
157a0 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e me))). (if (n
157b0 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 0a 09 ot currrecord)..
157c0 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 20 (begin.. (set!
157d0 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 6b 65 currrecord (make
157e0 2d 76 65 63 74 6f 72 20 31 31 20 23 66 29 29 0a -vector 11 #f)).
157f0 09 20 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 . (rmt:testmeta
15800 2d 61 64 64 2d 72 65 63 6f 72 64 20 74 65 73 74 -add-record test
15810 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 66 6f -name))). (fo
15820 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
15830 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 mbda (key).
15840 20 20 28 6c 65 74 2a 20 28 28 69 64 78 20 28 63 (let* ((idx (c
15850 61 64 72 20 6b 65 79 29 29 0a 09 20 20 20 20 20 adr key))..
15860 20 28 66 6c 64 20 28 63 61 72 20 20 6b 65 79 29 (fld (car key)
15870 29 0a 09 20 20 20 20 20 20 28 76 61 6c 20 28 63 ).. (val (c
15880 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 onfig-lookup tes
15890 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 t-conf "test_met
158a0 61 22 20 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 a" fld))).. ;; (
158b0 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 69 debug:print 5 "i
158c0 64 78 3a 20 22 20 69 64 78 20 22 20 66 6c 64 3a dx: " idx " fld:
158d0 20 22 20 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 " fld " val: "
158e0 76 61 6c 29 0a 09 20 28 69 66 20 28 61 6e 64 20 val).. (if (and
158f0 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f val (not (equal?
15900 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 (vector-ref cur
15910 72 72 65 63 6f 72 64 20 69 64 78 29 20 76 61 6c rrecord idx) val
15920 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e ))).. (begin
15930 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 .. (print
15940 22 55 70 64 61 74 69 6e 67 20 22 20 74 65 73 74 "Updating " test
15950 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 22 20 -name " " fld "
15960 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 20 20 to " val)..
15970 20 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d (rmt:testmeta-
15980 75 70 64 61 74 65 2d 66 69 65 6c 64 20 74 65 73 update-field tes
15990 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 t-name fld val))
159a0 29 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 74 ))). '(("aut
159b0 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 20 hor" 2)("owner"
159c0 33 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 22 3)("description"
159d0 20 34 29 28 22 72 65 76 69 65 77 65 64 22 20 35 4)("reviewed" 5
159e0 29 28 22 74 61 67 73 22 20 39 29 28 22 6a 6f 62 )("tags" 9)("job
159f0 67 72 6f 75 70 22 20 31 30 29 29 29 29 29 0a 0a group" 10)))))..
15a00 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 5f 6d ;; Update test_m
15a10 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 74 eta for all test
15a20 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a s.(define (runs:
15a30 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f update-all-test_
15a40 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 74 20 meta db). (let
15a50 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 ((test-names (te
15a60 73 74 73 3a 67 65 74 2d 61 6c 6c 29 29 29 20 3b sts:get-all))) ;
15a70 3b 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c ; (tests:get-val
15a80 69 64 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 id-tests))).
15a90 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
15aa0 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 (lambda (test-na
15ab0 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
15ac0 20 28 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 ((test-conf
15ad0 28 6d 74 3a 6c 61 7a 79 2d 72 65 61 64 2d 74 65 (mt:lazy-read-te
15ae0 73 74 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e st-config test-n
15af0 61 6d 65 29 29 29 0a 09 20 28 69 66 20 74 65 73 ame))).. (if tes
15b00 74 2d 63 6f 6e 66 20 28 72 75 6e 73 3a 75 70 64 t-conf (runs:upd
15b10 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 ate-test_meta te
15b20 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
15b30 66 29 29 29 29 0a 20 20 20 20 20 28 68 61 73 68 f)))). (hash
15b40 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
15b50 2d 6e 61 6d 65 73 29 29 29 29 0a 0a 3b 3b 20 54 -names))))..;; T
15b60 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 his could probab
15b70 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 64 ly be refactored
15b80 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 into one comple
15b90 78 20 71 75 65 72 79 20 2e 2e 2e 0a 3b 3b 20 4e x query ....;; N
15ba0 4f 54 20 50 4f 52 54 45 44 20 2d 20 44 4f 20 4e OT PORTED - DO N
15bb0 4f 54 20 55 53 45 20 59 45 54 0a 3b 3b 0a 28 64 OT USE YET.;;.(d
15bc0 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c efine (runs:roll
15bd0 75 70 2d 72 75 6e 20 6b 65 79 73 20 72 75 6e 6e up-run keys runn
15be0 61 6d 65 20 75 73 65 72 20 6b 65 79 76 61 6c 73 ame user keyvals
15bf0 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
15c00 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 4 "runs:rollup-
15c10 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 run, keys: " key
15c20 73 20 22 20 2d 72 75 6e 6e 61 6d 65 20 22 20 72 s " -runname " r
15c30 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 3a 20 22 unname " user: "
15c40 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 user). (let* (
15c50 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 (db
15c60 20 23 66 29 0a 09 20 3b 3b 20 72 65 67 69 73 74 #f).. ;; regist
15c70 65 72 20 72 75 6e 20 6f 70 65 72 61 74 65 73 20 er run operates
15c80 6f 6e 20 74 68 65 20 6d 61 69 6e 20 64 62 0a 09 on the main db..
15c90 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 (new-run-id
15ca0 20 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d (rmt:register-
15cb0 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e run keyvals runn
15cc0 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 ame "new" "n/a"
15cd0 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 user)).. (prev-t
15ce0 65 73 74 73 20 20 20 20 20 20 28 72 6d 74 3a 67 ests (rmt:g
15cf0 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 et-matching-prev
15d00 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
15d10 63 6f 72 64 73 20 6e 65 77 2d 72 75 6e 2d 69 64 cords new-run-id
15d20 20 22 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 "%" "%")).. (cu
15d30 72 72 2d 74 65 73 74 73 20 20 20 20 20 20 28 6d rr-tests (m
15d40 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
15d50 72 75 6e 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 run new-run-id "
15d60 25 2f 25 22 20 27 28 29 20 27 28 29 29 29 0a 09 %/%" '() '()))..
15d70 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 (curr-tests-has
15d80 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 h (make-hash-tab
15d90 6c 65 29 29 29 0a 20 20 20 20 28 72 6d 74 3a 75 le))). (rmt:u
15da0 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f pdate-run-event_
15db0 74 69 6d 65 20 6e 65 77 2d 72 75 6e 2d 69 64 29 time new-run-id)
15dc0 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 74 68 . ;; index th
15dd0 65 20 61 6c 72 65 61 64 79 20 73 61 76 65 64 20 e already saved
15de0 74 65 73 74 73 20 62 79 20 74 65 73 74 6e 61 6d tests by testnam
15df0 65 20 61 6e 64 20 69 74 65 6d 64 61 74 20 69 6e e and itemdat in
15e00 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
15e10 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
15e20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
15e30 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 tdat). (le
15e40 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 t* ((testname (
15e50 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
15e60 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 name testdat))..
15e70 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
15e80 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
15e90 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
15ea0 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e ).. (full-n
15eb0 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 ame (conc testna
15ec0 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
15ed0 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c ))).. (hash-tabl
15ee0 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 e-set! curr-test
15ef0 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 s-hash full-name
15f00 20 74 65 73 74 64 61 74 29 29 29 0a 20 20 20 20 testdat))).
15f10 20 63 75 72 72 2d 74 65 73 74 73 29 0a 20 20 20 curr-tests).
15f20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 ;; NOPE: Non-op
15f30 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 2e 20 timal approach.
15f40 54 72 79 20 74 68 69 73 20 69 6e 73 74 65 61 64 Try this instead
15f50 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 74 65 .. ;; 1. te
15f60 73 74 73 20 61 72 65 20 72 65 63 65 69 76 65 64 sts are received
15f70 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f 73 74 in a list, most
15f80 20 72 65 63 65 6e 74 20 66 69 72 73 74 0a 20 20 recent first.
15f90 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c 61 63 ;; 2. replac
15fa0 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 65 73 e the rollup tes
15fb0 74 20 77 69 74 68 20 74 68 65 20 6e 65 77 20 2a t with the new *
15fc0 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 6f 72 always*. (for
15fd0 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
15fe0 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 bda (testdat).
15ff0 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
16000 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d tname (db:test-
16010 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
16020 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 tdat)).. (i
16030 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
16040 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
16050 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
16060 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e (full-name (con
16070 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 c testname "/" i
16080 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
16090 20 20 28 70 72 65 76 2d 74 65 73 74 2d 64 61 74 (prev-test-dat
160a0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
160b0 2f 64 65 66 61 75 6c 74 20 63 75 72 72 2d 74 65 /default curr-te
160c0 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 sts-hash full-na
160d0 6d 65 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 me #f)).. (
160e0 74 65 73 74 2d 73 74 65 70 73 20 20 20 20 28 72 test-steps (r
160f0 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 mt:get-steps-for
16100 2d 74 65 73 74 20 28 64 62 3a 74 65 73 74 2d 67 -test (db:test-g
16110 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 et-id testdat)))
16120 0a 09 20 20 20 20 20 20 28 6e 65 77 2d 74 65 73 .. (new-tes
16130 74 2d 72 65 63 6f 72 64 20 23 66 29 29 0a 09 20 t-record #f))..
16140 3b 3b 20 72 65 70 6c 61 63 65 20 74 68 65 73 65 ;; replace these
16150 20 77 69 74 68 20 69 6e 73 65 72 74 20 2e 2e 2e with insert ...
16160 20 73 65 6c 65 63 74 0a 09 20 28 61 70 70 6c 79 select.. (apply
16170 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 sqlite3:execute
16180 20 0a 09 09 64 62 20 0a 09 09 28 63 6f 6e 63 20 ...db ...(conc
16190 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
161a0 43 45 20 49 4e 54 4f 20 74 65 73 74 73 20 28 72 CE INTO tests (r
161b0 75 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 un_id,testname,s
161c0 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e tate,status,even
161d0 74 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 70 75 6c t_time,host,cpul
161e0 6f 61 64 2c 64 69 73 6b 66 72 65 65 2c 75 6e 61 oad,diskfree,una
161f0 6d 65 2c 72 75 6e 64 69 72 2c 69 74 65 6d 5f 70 me,rundir,item_p
16200 61 74 68 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e ath,run_duration
16210 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d ,final_logf,comm
16220 65 6e 74 29 20 22 0a 09 09 20 20 20 20 20 20 22 ent) "... "
16230 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c VALUES (?,?,?,?,
16240 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
16250 3f 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 2d 72 75 ?,?);")...new-ru
16260 6e 2d 69 64 20 28 63 64 64 72 20 28 76 65 63 74 n-id (cddr (vect
16270 6f 72 2d 3e 6c 69 73 74 20 74 65 73 74 64 61 74 or->list testdat
16280 29 29 29 0a 09 20 28 73 65 74 21 20 6e 65 77 2d ))).. (set! new-
16290 74 65 73 74 64 61 74 20 28 63 61 72 20 28 6d 74 testdat (car (mt
162a0 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
162b0 75 6e 20 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 un new-run-id (c
162c0 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 onc testname "/"
162d0 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 29 20 item-path) '()
162e0 27 28 29 29 29 29 0a 09 20 28 68 61 73 68 2d 74 '()))).. (hash-t
162f0 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 able-set! curr-t
16300 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e ests-hash full-n
16310 61 6d 65 20 6e 65 77 2d 74 65 73 74 64 61 74 29 ame new-testdat)
16320 20 3b 3b 20 74 68 69 73 20 63 6f 75 6c 64 20 62 ;; this could b
16330 65 20 63 6f 6e 66 75 73 69 6e 67 2c 20 77 68 69 e confusing, whi
16340 63 68 20 72 65 63 6f 72 64 20 73 68 6f 75 6c 64 ch record should
16350 20 67 6f 20 69 6e 74 6f 20 74 68 65 20 6c 6f 6f go into the loo
16360 6b 75 70 20 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 kup table?.. ;;
16370 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 Now duplicate th
16380 65 20 74 65 73 74 20 73 74 65 70 73 0a 09 20 28 e test steps.. (
16390 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 debug:print 4 "C
163a0 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 opying records i
163b0 6e 20 74 65 73 74 5f 73 74 65 70 73 20 66 72 6f n test_steps fro
163c0 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a m test_id=" (db:
163d0 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
163e0 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a dat) " to " (db:
163f0 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
16400 74 65 73 74 64 61 74 29 29 0a 09 20 28 63 64 62 testdat)).. (cdb
16410 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 3b 3b 20 74 :remote-run ;; t
16420 6f 20 62 65 20 72 65 70 6c 61 63 65 64 2c 20 6e o be replaced, n
16430 6f 74 65 3a 20 74 68 69 73 20 72 6f 75 74 69 6e ote: this routin
16440 65 20 69 73 20 6e 6f 74 20 75 73 65 64 20 63 75 e is not used cu
16450 72 72 65 6e 74 6c 79 0a 09 20 20 28 6c 61 6d 62 rrently.. (lamb
16460 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c 69 da ().. (sqli
16470 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 te3:execute ..
16480 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f db .. (co
16490 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
164a0 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f PLACE INTO test_
164b0 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 steps (test_id,s
164c0 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 tepname,state,st
164d0 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c atus,event_time,
164e0 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 comment) "...
164f0 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 "SELECT " (db:te
16500 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 st-get-id new-te
16510 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d stdat) ",stepnam
16520 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 e,state,status,e
16530 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e vent_time,commen
16540 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 t FROM test_step
16550 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d s WHERE test_id=
16560 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 ?;").. (db:t
16570 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
16580 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 at)).. ;; Now
16590 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 duplicate the t
165a0 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 64 est data.. (d
165b0 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f ebug:print 4 "Co
165c0 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e pying records in
165d0 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 test_data from
165e0 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 test_id=" (db:te
165f0 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
16600 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 t) " to " (db:te
16610 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 st-get-id new-te
16620 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 71 stdat)).. (sq
16630 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 lite3:execute ..
16640 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 db .. (
16650 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
16660 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
16670 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c t_data (test_id,
16680 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c category,variabl
16690 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 e,value,expected
166a0 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 ,tol,units,comme
166b0 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 nt) "... "SELE
166c0 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 CT " (db:test-ge
166d0 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
166e0 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 ) ",category,var
166f0 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 iable,value,expe
16700 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 cted,tol,units,c
16710 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 omment FROM test
16720 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 73 74 _data WHERE test
16730 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 _id=?;").. (
16740 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
16750 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 0a estdat)))).. )).
16760 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 29 prev-tests)
16770 29 29 0a 09 20 0a 20 20 20 20 20 0a )).. . .