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 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
02d0: 73 65 73 20 66 69 6c 65 64 62 29 29 0a 0a 28 69 ses filedb))..(i
02e0: 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 nclude "common_r
02f0: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0300: 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 clude "key_recor
0310: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0320: 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 e "db_records.sc
0330: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 m").(include "ru
0340: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
0350: 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f 72 (include "test_r
0360: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 ecords.scm")..(d
0370: 65 66 69 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 efine (runs:test
0380: 2d 67 65 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 -get-full-path t
0390: 65 73 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 est). (let* ((t
03a0: 65 73 74 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 estname (db:test
03b0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 -get-testname
03c0: 74 65 73 74 29 29 0a 09 20 28 69 74 65 6d 70 61 test)).. (itempa
03d0: 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d th (db:test-get-
03e0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 item-path test))
03f0: 29 0a 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 ). (conc test
0400: 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f name (if (equal?
0410: 20 69 74 65 6d 70 61 74 68 20 22 22 29 20 22 22 itempath "") ""
0420: 20 28 63 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 (conc "(" itemp
0430: 61 74 68 20 22 29 22 29 29 29 29 29 0a 0a 3b 3b ath ")")))))..;;
0440: 20 54 68 69 73 20 69 73 20 74 68 65 20 2a 6e 65 This is the *ne
0450: 77 2a 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 w* methodology.
0460: 4f 6e 65 20 72 65 63 6f 72 64 20 74 6f 20 69 6e One record to in
0470: 66 6f 72 6d 20 74 68 65 6d 20 61 6e 64 20 69 6e form them and in
0480: 20 74 68 65 20 63 68 61 6f 73 2c 20 6f 72 67 61 the chaos, orga
0490: 6e 69 73 65 20 74 68 65 6d 2e 0a 3b 3b 0a 28 64 nise them..;;.(d
04a0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 72 65 61 efine (runs:crea
04b0: 74 65 2d 72 75 6e 2d 72 65 63 6f 72 64 29 0a 20 te-run-record).
04c0: 20 28 6c 65 74 2a 20 28 28 6d 63 6f 6e 66 69 67 (let* ((mconfig
04d0: 20 20 20 20 20 20 28 69 66 20 2a 63 6f 6e 66 69 (if *confi
04e0: 67 64 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 gdat*...
04f0: 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 *configdat*..
0500: 09 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 . (if
0510: 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 66 6f (launch:setup-fo
0520: 72 2d 72 75 6e 29 0a 09 09 20 20 20 20 20 20 20 r-run)...
0530: 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 *configd
0540: 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 20 20 at*...
0550: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 (begin...
0560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0570: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
0580: 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 74 RROR: Called set
0590: 75 70 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 61 up in a non-mega
05a0: 74 65 73 74 20 61 72 65 61 2c 20 65 78 69 74 69 test area, exiti
05b0: 6e 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 ng")...
05c0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
05d0: 29 29 29 29 0a 09 20 20 28 72 75 6e 72 65 63 20 )))).. (runrec
05e0: 20 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 65 (runs:runre
05f0: 63 2d 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 0a c-make-record)).
0600: 09 20 20 28 74 61 72 67 65 74 20 20 20 20 20 20 . (target
0610: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
0620: 2d 74 61 72 67 65 74 29 29 0a 09 20 20 28 72 75 -target)).. (ru
0630: 6e 6e 61 6d 65 20 20 20 20 20 28 6f 72 20 28 61 nname (or (a
0640: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
0650: 6e 6e 61 6d 65 22 29 0a 09 09 20 20 20 20 20 20 nname")...
0660: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
0670: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 29 rg ":runname")))
0680: 0a 09 20 20 28 74 65 73 74 70 61 74 74 20 20 20 .. (testpatt
0690: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
06a0: 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a rg "-testpatt").
06b0: 09 09 20 20 20 20 20 20 20 20 20 20 20 28 61 72 .. (ar
06c0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
06d0: 74 65 73 74 73 22 29 29 29 0a 09 20 20 28 6b 65 tests"))).. (ke
06e0: 79 73 20 20 20 20 20 20 20 20 28 6b 65 79 73 3a ys (keys:
06f0: 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 config-get-field
0700: 73 20 6d 63 6f 6e 66 69 67 29 29 0a 09 20 20 28 s mconfig)).. (
0710: 6b 65 79 76 61 6c 73 20 20 20 20 20 28 6b 65 79 keyvals (key
0720: 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c s:target->keyval
0730: 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 keys target))..
0740: 20 20 28 74 6f 70 70 61 74 68 20 20 20 20 20 2a (toppath *
0750: 74 6f 70 70 61 74 68 2a 29 0a 09 20 20 28 65 6e toppath*).. (en
0760: 76 64 61 74 20 20 20 20 20 20 6b 65 79 76 61 6c vdat keyval
0770: 73 29 20 3b 3b 20 69 6e 69 74 69 61 6c 20 76 61 s) ;; initial va
0780: 6c 75 65 73 20 73 74 61 72 74 20 77 69 74 68 20 lues start with
0790: 6b 65 79 76 61 6c 73 0a 09 20 20 28 72 75 6e 63 keyvals.. (runc
07a0: 6f 6e 66 69 67 20 20 20 23 66 29 0a 09 20 20 28 onfig #f).. (
07b0: 73 65 72 76 65 72 64 61 74 20 20 20 28 69 66 20 serverdat (if
07c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
07d0: 73 65 72 76 65 72 22 29 0a 09 09 09 20 20 20 2a server").... *
07e0: 72 75 6e 72 65 6d 6f 74 65 2a 0a 09 09 09 20 20 runremote*....
07f0: 20 23 66 29 29 20 3b 3b 20 74 6f 20 62 65 20 75 #f)) ;; to be u
0800: 73 65 64 20 6c 61 74 65 72 0a 09 20 20 28 74 72 sed later.. (tr
0810: 61 6e 73 70 6f 72 74 20 20 20 28 6f 72 20 28 61 ansport (or (a
0820: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 72 rgs:get-arg "-tr
0830: 61 6e 73 70 6f 72 74 22 29 20 27 68 74 74 70 29 ansport") 'http)
0840: 29 0a 09 20 20 28 72 75 6e 2d 69 64 20 20 20 20 ).. (run-id
0850: 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 53 65 #f)). ;; Se
0860: 74 20 61 6c 6c 20 74 68 65 20 65 6e 76 69 72 6f t all the enviro
0870: 6e 6d 65 6e 74 20 76 61 72 73 20 77 65 20 6b 6e nment vars we kn
0880: 6f 77 20 73 6f 20 66 61 72 2c 20 73 74 61 72 74 ow so far, start
0890: 20 77 69 74 68 20 6b 65 79 73 0a 20 20 20 20 28 with keys. (
08a0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
08b0: 20 28 6b 65 79 76 61 6c 29 0a 09 09 28 73 65 74 (keyval)...(set
08c0: 65 6e 76 20 28 63 61 72 20 6b 65 79 76 61 6c 29 env (car keyval)
08d0: 28 63 61 64 72 20 6b 65 79 76 61 6c 29 29 29 0a (cadr keyval))).
08e0: 09 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 0a . keyvals).
08f0: 20 20 20 20 3b 3b 20 53 65 74 20 75 70 20 76 61 ;; Set up va
0900: 72 69 6f 75 73 20 61 6e 64 20 73 75 6e 64 72 79 rious and sundry
0910: 20 6b 6e 6f 77 6e 20 76 61 72 73 20 68 65 72 65 known vars here
0920: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
0930: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 _RUN_AREA_HOME"
0940: 74 6f 70 70 61 74 68 29 0a 20 20 20 20 28 73 65 toppath). (se
0950: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 tenv "MT_RUNNAME
0960: 22 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 " runname). (
0970: 73 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 setenv "MT_TARGE
0980: 54 22 20 20 74 61 72 67 65 74 29 0a 20 20 20 20 T" target).
0990: 28 73 65 74 21 20 65 6e 76 64 61 74 20 28 61 70 (set! envdat (ap
09a0: 70 65 6e 64 20 0a 09 09 20 20 65 6e 76 64 61 74 pend ... envdat
09b0: 0a 09 09 20 20 28 6c 69 73 74 20 28 6c 69 73 74 ... (list (list
09c0: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
09d0: 4d 45 22 20 74 6f 70 70 61 74 68 29 0a 09 09 09 ME" toppath)....
09e0: 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 4e 41 4d (list "MT_RUNNAM
09f0: 45 22 20 20 20 20 20 20 20 72 75 6e 6e 61 6d 65 E" runname
0a00: 29 0a 09 09 09 28 6c 69 73 74 20 22 4d 54 5f 54 )....(list "MT_T
0a10: 41 52 47 45 54 22 20 20 20 20 20 20 20 20 74 61 ARGET" ta
0a20: 72 67 65 74 29 29 29 29 0a 20 20 20 20 3b 3b 20 rget)))). ;;
0a30: 4e 6f 77 20 63 61 6e 20 72 65 61 64 20 74 68 65 Now can read the
0a40: 20 72 75 6e 63 6f 6e 66 69 67 73 20 66 69 6c 65 runconfigs file
0a50: 0a 20 20 20 20 3b 3b 20 0a 20 20 20 20 28 73 65 . ;; . (se
0a60: 74 21 20 72 75 6e 63 6f 6e 66 69 67 20 28 72 65 t! runconfig (re
0a70: 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 ad-config (conc
0a80: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
0a90: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
0aa0: 20 23 66 20 23 74 20 73 65 63 74 69 6f 6e 73 3a #f #t sections:
0ab0: 20 28 6c 69 73 74 20 22 64 65 66 61 75 6c 74 22 (list "default"
0ac0: 20 74 61 72 67 65 74 29 29 29 0a 20 20 20 20 28 target))). (
0ad0: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
0ae0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0af0: 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 3a runconfig (args:
0b00: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
0b10: 67 22 29 20 23 66 29 29 0a 09 28 62 65 67 69 6e g") #f))..(begin
0b20: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
0b30: 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 20 28 61 0 "ERROR: [" (a
0b40: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
0b50: 71 74 61 72 67 22 29 20 22 5d 20 6e 6f 74 20 66 qtarg") "] not f
0b60: 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e 63 6f 6e ound in " runcon
0b70: 66 69 67 66 29 0a 09 20 20 28 69 66 20 64 62 20 figf).. (if db
0b80: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
0b90: 65 21 20 64 62 29 29 0a 09 20 20 28 65 78 69 74 e! db)).. (exit
0ba0: 20 31 29 29 29 0a 20 20 20 20 3b 3b 20 4e 6f 77 1))). ;; Now
0bb0: 20 68 61 76 65 20 72 75 6e 63 6f 6e 66 69 67 73 have runconfigs
0bc0: 20 64 61 74 61 20 6c 6f 61 64 65 64 2c 20 73 65 data loaded, se
0bd0: 74 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 t environment va
0be0: 72 73 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 rs. (for-each
0bf0: 20 28 6c 61 6d 62 64 61 20 28 73 65 63 74 69 6f (lambda (sectio
0c00: 6e 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 n)...(for-each (
0c10: 6c 61 6d 62 64 61 20 28 76 61 72 76 61 6c 29 0a lambda (varval).
0c20: 09 09 09 20 20 20 20 28 73 65 74 21 20 65 6e 76 ... (set! env
0c30: 64 61 74 20 28 61 70 70 65 6e 64 20 65 6e 76 64 dat (append envd
0c40: 61 74 20 28 6c 69 73 74 20 76 61 72 76 61 6c 29 at (list varval)
0c50: 29 29 0a 09 09 09 20 20 20 20 28 73 61 66 65 2d )).... (safe-
0c60: 73 65 74 65 6e 76 20 28 63 61 72 20 76 61 72 76 setenv (car varv
0c70: 61 6c 29 28 63 61 64 72 20 76 61 72 76 61 6c 29 al)(cadr varval)
0c80: 29 29 0a 09 09 09 20 20 28 63 6f 6e 66 69 67 66 )).... (configf
0c90: 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 72 75 6e :get-section run
0ca0: 63 6f 6e 66 69 67 20 73 65 63 74 69 6f 6e 29 29 config section))
0cb0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 22 ).. (list "
0cc0: 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 29 default" target)
0cd0: 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 74 61 ). (vector ta
0ce0: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 rget runname tes
0cf0: 74 70 61 74 74 20 6b 65 79 73 20 6b 65 79 76 61 tpatt keys keyva
0d00: 6c 73 20 65 6e 76 64 61 74 20 6d 63 6f 6e 66 69 ls envdat mconfi
0d10: 67 20 72 75 6e 63 6f 6e 66 69 67 20 73 65 72 76 g runconfig serv
0d20: 65 72 64 61 74 20 74 72 61 6e 73 70 6f 72 74 20 erdat transport
0d30: 64 62 20 74 6f 70 70 61 74 68 20 72 75 6e 2d 69 db toppath run-i
0d40: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
0d50: 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 73 74 uns:set-megatest
0d60: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
0d70: 20 23 21 6b 65 79 20 28 69 6e 6b 65 79 73 20 23 #!key (inkeys #
0d80: 66 29 28 69 6e 72 75 6e 6e 61 6d 65 20 23 66 29 f)(inrunname #f)
0d90: 28 69 6e 6b 65 79 76 61 6c 73 20 23 66 29 29 0a (inkeyvals #f)).
0da0: 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 (let* ((target
0db0: 20 20 20 20 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a (or (common:
0dc0: 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 29 args-get-target)
0dd0: 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e ....(get-environ
0de0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
0df0: 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 20 28 T_TARGET"))).. (
0e00: 6b 65 79 73 20 20 20 20 28 69 66 20 69 6e 6b 65 keys (if inke
0e10: 79 73 20 20 20 20 69 6e 6b 65 79 73 20 20 20 20 ys inkeys
0e20: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 29 (rmt:get-keys)))
0e30: 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 20 28 69 .. (keyvals (i
0e40: 66 20 69 6e 6b 65 79 76 61 6c 73 20 69 6e 6b 65 f inkeyvals inke
0e50: 79 76 61 6c 73 20 28 6b 65 79 73 3a 74 61 72 67 yvals (keys:targ
0e60: 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 et->keyval keys
0e70: 74 61 72 67 65 74 29 29 29 0a 09 20 28 76 61 6c target))).. (val
0e80: 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
0e90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
0ea0: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
0eb0: 69 64 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 0a id* run-id #f)).
0ec0: 09 20 28 6c 69 6e 6b 2d 74 72 65 65 20 28 63 6f . (link-tree (co
0ed0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
0ee0: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
0ef0: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 "linktree"))).
0f00: 20 20 20 3b 3b 20 67 65 74 20 74 68 65 20 69 6e ;; get the in
0f10: 66 6f 20 66 72 6f 6d 20 74 68 65 20 64 62 20 61 fo from the db a
0f20: 6e 64 20 70 75 74 20 69 74 20 69 6e 20 74 68 65 nd put it in the
0f30: 20 63 61 63 68 65 0a 20 20 20 20 28 69 66 20 6c cache. (if l
0f40: 69 6e 6b 2d 74 72 65 65 0a 09 28 73 65 74 65 6e ink-tree..(seten
0f50: 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 20 v "MT_LINKTREE"
0f60: 6c 69 6e 6b 2d 74 72 65 65 29 0a 09 28 64 65 62 link-tree)..(deb
0f70: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
0f80: 52 3a 20 6c 69 6e 6b 74 72 65 65 20 6e 6f 74 20 R: linktree not
0f90: 73 65 74 2c 20 73 68 6f 75 6c 64 20 62 65 20 73 set, should be s
0fa0: 65 74 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 et in megatest.c
0fb0: 6f 6e 66 69 67 20 69 6e 20 5b 73 65 74 75 70 5d onfig in [setup]
0fc0: 20 73 65 63 74 69 6f 6e 2e 22 29 29 0a 20 20 20 section.")).
0fd0: 20 28 69 66 20 28 6e 6f 74 20 76 61 6c 73 29 0a (if (not vals).
0fe0: 09 28 6c 65 74 20 28 28 68 74 20 28 6d 61 6b 65 .(let ((ht (make
0ff0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 -hash-table)))..
1000: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
1010: 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d t! *env-vars-by-
1020: 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 68 run-id* run-id h
1030: 74 29 0a 09 20 20 28 73 65 74 21 20 76 61 6c 73 t).. (set! vals
1040: 20 68 74 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 ht).. (for-eac
1050: 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6b h.. (lambda (k
1060: 65 79 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d ey).. (hash-
1070: 74 61 62 6c 65 2d 73 65 74 21 20 76 61 6c 73 20 table-set! vals
1080: 28 63 61 72 20 6b 65 79 29 20 28 63 61 64 72 20 (car key) (cadr
1090: 6b 65 79 29 29 29 0a 09 20 20 20 6b 65 79 76 61 key))).. keyva
10a0: 6c 73 29 29 29 0a 20 20 20 20 3b 3b 20 66 72 6f ls))). ;; fro
10b0: 6d 20 74 68 65 20 63 61 63 68 65 64 20 64 61 74 m the cached dat
10c0: 61 20 73 65 74 20 74 68 65 20 76 61 72 73 0a 20 a set the vars.
10d0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 (hash-table-f
10e0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 76 61 6c or-each. val
10f0: 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 s. (lambda (
1100: 6b 65 79 20 76 61 6c 29 0a 20 20 20 20 20 20 20 key val).
1110: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
1120: 73 65 74 65 6e 76 20 22 20 6b 65 79 20 22 20 22 setenv " key " "
1130: 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 61 val). (sa
1140: 66 65 2d 73 65 74 65 6e 76 20 6b 65 79 20 76 61 fe-setenv key va
1150: 6c 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f l))). (if (no
1160: 74 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 t (get-environme
1170: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
1180: 54 41 52 47 45 54 22 29 29 28 73 65 74 65 6e 76 TARGET"))(setenv
1190: 20 22 4d 54 5f 54 41 52 47 45 54 22 20 74 61 72 "MT_TARGET" tar
11a0: 67 65 74 29 29 0a 20 20 20 20 28 61 6c 69 73 74 get)). (alist
11b0: 2d 3e 65 6e 76 2d 76 61 72 73 20 28 68 61 73 68 ->env-vars (hash
11c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
11d0: 6c 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 lt *configdat* "
11e0: 65 6e 76 2d 6f 76 65 72 72 69 64 65 22 20 27 28 env-override" '(
11f0: 29 29 29 0a 20 20 20 20 3b 3b 20 4c 65 74 73 20 ))). ;; Lets
1200: 75 73 65 20 74 68 69 73 20 61 73 20 61 6e 20 6f use this as an o
1210: 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 70 75 pportunity to pu
1220: 74 20 4d 54 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 t MT_RUNNAME in
1230: 74 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a the environment.
1240: 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 (let ((runna
1250: 6d 65 20 20 28 69 66 20 69 6e 72 75 6e 6e 61 6d me (if inrunnam
1260: 65 20 69 6e 72 75 6e 6e 61 6d 65 20 28 72 6d 74 e inrunname (rmt
1270: 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 :get-run-name-fr
1280: 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 29 29 29 29 om-id run-id))))
1290: 0a 20 20 20 20 20 20 28 69 66 20 72 75 6e 6e 61 . (if runna
12a0: 6d 65 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d me.. (setenv "M
12b0: 54 5f 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 T_RUNNAME" runna
12c0: 6d 65 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 me).. (debug:pr
12d0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f int 0 "ERROR: no
12e0: 20 76 61 6c 75 65 20 66 6f 72 20 72 75 6e 6e 61 value for runna
12f0: 6d 65 20 66 6f 72 20 69 64 20 22 20 72 75 6e 2d me for id " run-
1300: 69 64 29 29 29 0a 20 20 20 20 28 73 65 74 65 6e id))). (seten
1310: 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 v "MT_RUN_AREA_H
1320: 4f 4d 45 22 20 2a 74 6f 70 70 61 74 68 2a 29 29 OME" *toppath*))
1330: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d )..(define (set-
1340: 69 74 65 6d 2d 65 6e 76 2d 76 61 72 73 20 69 74 item-env-vars it
1350: 65 6d 64 61 74 29 0a 20 20 28 66 6f 72 2d 65 61 emdat). (for-ea
1360: 63 68 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ch (lambda (item
1370: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
1380: 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 print 2 "setenv
1390: 22 20 28 63 61 72 20 69 74 65 6d 29 20 22 20 22 " (car item) " "
13a0: 20 28 63 61 64 72 20 69 74 65 6d 29 29 0a 09 20 (cadr item))..
13b0: 20 20 20 20 20 28 73 65 74 65 6e 76 20 28 63 61 (setenv (ca
13c0: 72 20 69 74 65 6d 29 20 28 63 61 64 72 20 69 74 r item) (cadr it
13d0: 65 6d 29 29 29 0a 09 20 20 20 20 69 74 65 6d 64 em))).. itemd
13e0: 61 74 29 29 0a 0a 3b 3b 20 45 76 65 72 79 20 74 at))..;; Every t
13f0: 69 6d 65 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ime can-run-more
1400: 2d 74 65 73 74 73 20 69 73 20 63 61 6c 6c 65 64 -tests is called
1410: 20 69 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 64 increment the d
1420: 65 6c 61 79 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a elay.;;.;; NOTE:
1430: 20 57 65 20 72 75 6e 20 74 68 69 73 20 73 65 72 We run this ser
1440: 76 65 72 2d 73 69 64 65 21 21 20 44 6f 20 6e 6f ver-side!! Do no
1450: 74 20 75 73 65 20 74 68 69 73 20 67 6c 6f 62 61 t use this globa
1460: 6c 20 65 78 63 65 70 74 20 69 6e 20 74 68 65 20 l except in the
1470: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
1480: 65 2d 74 65 73 74 73 20 72 6f 75 74 69 6e 65 0a e-tests routine.
1490: 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 ;;.(define *last
14a0: 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 -num-running-tes
14b0: 74 73 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a ts* 0).(define *
14c0: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
14d0: 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 30 e-tests-count* 0
14e0: 29 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ).(define (runs:
14f0: 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d shrink-can-run-m
1500: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 ore-tests-count)
1510: 0a 20 20 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 . (set! *runs:c
1520: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
1530: 73 2d 63 6f 75 6e 74 2a 20 30 29 29 20 3b 3b 20 s-count* 0)) ;;
1540: 28 2f 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e (/ *runs:can-run
1550: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
1560: 74 2a 20 32 29 29 29 0a 0a 3b 3b 20 54 65 6d 70 t* 2)))..;; Temp
1570: 6f 72 61 72 79 20 67 6c 6f 62 61 6c 73 2e 20 4d orary globals. M
1580: 6f 76 65 20 74 68 65 73 65 20 69 6e 74 6f 20 74 ove these into t
1590: 68 65 20 6c 6f 67 69 63 20 6f 72 20 69 6e 74 6f he logic or into
15a0: 20 63 6f 6d 6d 6f 6e 0a 3b 3b 0a 28 64 65 66 69 common.;;.(defi
15b0: 6e 65 20 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 ne *seen-cant-ru
15c0: 6e 2d 74 65 73 74 73 2a 20 28 6d 61 6b 65 2d 68 n-tests* (make-h
15d0: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 75 ash-table)) ;; u
15e0: 73 65 20 74 6f 20 74 72 61 63 6b 20 74 65 73 74 se to track test
15f0: 73 20 74 68 61 74 20 77 65 20 73 75 73 70 65 63 s that we suspec
1600: 74 20 63 61 6e 6e 6f 74 20 62 65 20 72 75 6e 0a t cannot be run.
1610: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 69 6e (define (runs:in
1620: 63 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 c-cant-run-tests
1630: 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 68 61 testname). (ha
1640: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 73 sh-table-set! *s
1650: 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 een-cant-run-tes
1660: 74 73 2a 20 74 65 73 74 6e 61 6d 65 0a 09 09 20 ts* testname...
1670: 20 20 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 (+ (hash-table
1680: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 -ref/default *se
1690: 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 en-cant-run-test
16a0: 73 2a 20 74 65 73 74 6e 61 6d 65 20 30 29 20 31 s* testname 0) 1
16b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
16c0: 6e 73 3a 63 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e ns:can-keep-runn
16d0: 69 6e 67 3f 20 74 65 73 74 6e 61 6d 65 20 6e 29 ing? testname n)
16e0: 0a 20 20 28 3c 20 28 68 61 73 68 2d 74 61 62 6c . (< (hash-tabl
16f0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 e-ref/default *s
1700: 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 een-cant-run-tes
1710: 74 73 2a 20 74 65 73 74 6e 61 6d 65 20 30 29 20 ts* testname 0)
1720: 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 72 75 n))..(define *ru
1730: 6e 73 3a 64 65 6e 6f 69 73 65 2a 20 28 6d 61 6b ns:denoise* (mak
1740: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1750: 3b 20 6b 65 79 20 3d 3e 20 6c 61 73 74 2d 74 69 ; key => last-ti
1760: 6d 65 2d 72 61 6e 0a 0a 28 64 65 66 69 6e 65 20 me-ran..(define
1770: 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 6b (runs:lownoise k
1780: 65 79 20 77 61 69 74 76 61 6c 29 0a 20 20 28 6c ey waitval). (l
1790: 65 74 20 28 28 6c 61 73 74 74 69 6d 65 20 28 68 et ((lasttime (h
17a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
17b0: 66 61 75 6c 74 20 2a 72 75 6e 73 3a 64 65 6e 6f fault *runs:deno
17c0: 69 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 28 63 ise* key 0))..(c
17d0: 75 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 urrtime (current
17e0: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 -seconds))).
17f0: 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 (if (> (- currti
1800: 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 me lasttime) wai
1810: 74 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 tval)..(begin..
1820: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
1830: 21 20 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 65 2a ! *runs:denoise*
1840: 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a 09 key currtime)..
1850: 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 #t)..#f)))..(d
1860: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d efine (runs:can-
1870: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 run-more-tests r
1880: 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 20 6d un-id jobgroup m
1890: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
18a0: 62 73 29 0a 20 20 28 74 68 72 65 61 64 2d 73 6c bs). (thread-sl
18b0: 65 65 70 21 20 28 63 6f 6e 64 0a 09 09 20 20 28 eep! (cond... (
18c0: 28 3e 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e (> *runs:can-run
18d0: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
18e0: 74 2a 20 32 30 29 20 32 29 3b 3b 20 6f 62 76 69 t* 20) 2);; obvi
18f0: 6f 75 73 6c 79 20 68 61 76 65 6e 27 74 20 68 61 ously haven't ha
1900: 64 20 61 6e 79 20 77 6f 72 6b 20 74 6f 20 64 6f d any work to do
1910: 20 66 6f 72 20 61 20 77 68 69 6c 65 0a 09 09 20 for a while...
1920: 20 28 65 6c 73 65 20 30 29 29 29 0a 20 20 28 6c (else 0))). (l
1930: 65 74 2a 20 28 28 6e 75 6d 2d 72 75 6e 6e 69 6e et* ((num-runnin
1940: 67 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 g (r
1950: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
1960: 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 ts-running run-i
1970: 64 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 d)).. (num-runni
1980: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 ng-in-jobgroup (
1990: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
19a0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
19b0: 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 6a obgroup run-id j
19c0: 6f 62 67 72 6f 75 70 29 29 0a 09 20 28 6a 6f 62 obgroup)).. (job
19d0: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 -group-limit
19e0: 20 20 20 20 20 28 6c 65 74 20 28 28 6a 6f 62 67 (let ((jobg
19f0: 2d 63 6f 75 6e 74 20 28 63 6f 6e 66 69 67 2d 6c -count (config-l
1a00: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
1a10: 2a 20 22 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f * "jobgroups" jo
1a20: 62 67 72 6f 75 70 29 29 29 0a 09 09 09 09 20 20 bgroup))).....
1a30: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6a (if (string? j
1a40: 6f 62 67 2d 63 6f 75 6e 74 29 0a 09 09 09 09 09 obg-count)......
1a50: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
1a60: 6a 6f 62 67 2d 63 6f 75 6e 74 29 0a 09 09 09 09 jobg-count).....
1a70: 09 6a 6f 62 67 2d 63 6f 75 6e 74 29 29 29 29 0a .jobg-count)))).
1a80: 20 20 20 20 28 69 66 20 28 3e 20 28 2b 20 6e 75 (if (> (+ nu
1a90: 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 m-running num-ru
1aa0: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
1ab0: 70 29 20 30 29 0a 09 28 73 65 74 21 20 2a 72 75 p) 0)..(set! *ru
1ac0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1ad0: 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 28 2b 20 tests-count* (+
1ae0: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
1af0: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
1b00: 31 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 1))). (if (no
1b10: 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d t (eq? *last-num
1b20: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
1b30: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 28 num-running))..(
1b40: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
1b50: 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e print 2 "max-con
1b60: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 current-jobs: "
1b70: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1b80: 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 obs ", num-runni
1b90: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
1ba0: 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c 61 73 g).. (set! *las
1bb0: 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 t-num-running-te
1bc0: 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 sts* num-running
1bd0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
1be0: 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 (eq? 0 *globale
1bf0: 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 28 6c xitstatus*))..(l
1c00: 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 ist #f num-runni
1c10: 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 ng num-running-i
1c20: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 n-jobgroup max-c
1c30: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a oncurrent-jobs j
1c40: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 0a ob-group-limit).
1c50: 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d .(let ((can-not-
1c60: 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 run-more (cond..
1c70: 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f ... ;; if max-co
1c80: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 ncurrent-jobs is
1c90: 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e 75 6d set and the num
1ca0: 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 ber running is g
1cb0: 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 reater ..... ;;
1cc0: 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 61 6e than it than can
1cd0: 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 not run more job
1ce0: 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d 61 78 s..... ((and max
1cf0: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1d00: 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (>= num-running
1d10: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1d20: 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 28 69 66 jobs))..... (if
1d30: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
1d40: 22 6d 63 6a 20 6d 73 67 22 20 36 30 29 0a 09 09 "mcj msg" 60)...
1d50: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
1d60: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
1d70: 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 Max running job
1d80: 73 20 65 78 63 65 65 64 65 64 2c 20 63 75 72 72 s exceeded, curr
1d90: 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 ent number runni
1da0: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
1db0: 67 20 0a 09 09 09 09 09 09 20 20 20 22 2c 20 6d g ....... ", m
1dc0: 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f ax_concurrent_jo
1dd0: 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 bs: " max-concur
1de0: 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 09 09 rent-jobs)).....
1df0: 20 20 23 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 #t)..... ;; if
1e00: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
1e10: 20 69 73 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 is set and numb
1e20: 65 72 20 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 er of jobs in th
1e30: 65 20 67 72 6f 75 70 20 69 73 20 67 72 65 61 74 e group is great
1e40: 65 72 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 er..... ;; than
1e50: 74 68 65 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 the limit then c
1e60: 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a annot run more j
1e70: 6f 62 73 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 obs of this kind
1e80: 0a 09 09 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d ..... ((and job-
1e90: 67 72 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 group-limit.....
1ea0: 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 (>= num-r
1eb0: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
1ec0: 75 70 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d up job-group-lim
1ed0: 69 74 29 29 0a 09 09 09 09 20 20 28 69 66 20 28 it))..... (if (
1ee0: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 runs:lownoise (c
1ef0: 6f 6e 63 20 22 6d 61 78 6a 6f 62 67 72 6f 75 70 onc "maxjobgroup
1f00: 20 22 20 6a 6f 62 67 72 6f 75 70 29 20 36 30 29 " jobgroup) 60)
1f10: 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
1f20: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 g:print 1 "WARNI
1f30: 4e 47 3a 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f NG: number of jo
1f40: 62 73 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 bs " num-running
1f50: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 -in-jobgroup ...
1f60: 09 09 09 09 20 20 20 22 20 69 6e 20 6a 6f 62 67 .... " in jobg
1f70: 72 6f 75 70 20 5c 22 22 20 6a 6f 62 67 72 6f 75 roup \"" jobgrou
1f80: 70 20 22 5c 22 20 65 78 63 65 65 64 73 20 6c 69 p "\" exceeds li
1f90: 6d 69 74 20 6f 66 20 22 20 6a 6f 62 2d 67 72 6f mit of " job-gro
1fa0: 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 up-limit)).....
1fb0: 20 23 74 29 0a 09 09 09 09 20 28 65 6c 73 65 20 #t)..... (else
1fc0: 23 66 29 29 29 29 0a 09 20 20 28 6c 69 73 74 20 #f)))).. (list
1fd0: 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e (not can-not-run
1fe0: 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 -more) num-runni
1ff0: 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 ng num-running-i
2000: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 n-jobgroup max-c
2010: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a oncurrent-jobs j
2020: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 ob-group-limit))
2030: 29 29 29 0a 0a 0a 3b 3b 20 20 74 65 73 74 2d 6e )))...;; test-n
2040: 61 6d 65 73 3a 20 43 6f 6d 6d 61 20 73 65 70 61 ames: Comma sepa
2050: 72 61 74 65 64 20 70 61 74 74 65 72 6e 73 20 73 rated patterns s
2060: 61 6d 65 20 61 73 20 74 65 73 74 2d 70 61 74 74 ame as test-patt
2070: 73 20 62 75 74 20 75 73 65 64 20 69 6e 20 73 65 s but used in se
2080: 6c 65 63 74 69 6f 6e 20 0a 3b 3b 20 20 20 20 20 lection .;;
2090: 20 20 20 20 20 20 20 20 20 6f 66 20 74 65 73 74 of test
20a0: 73 20 74 6f 20 72 75 6e 2e 20 54 68 65 20 69 74 s to run. The it
20b0: 65 6d 20 70 6f 72 74 69 6f 6e 73 20 61 72 65 20 em portions are
20c0: 6e 6f 74 20 72 65 73 70 65 63 74 65 64 2e 0a 3b not respected..;
20d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 ; F
20e0: 49 58 4d 45 3a 20 65 72 72 6f 72 20 6f 75 74 20 IXME: error out
20f0: 69 66 20 2f 70 61 74 74 20 73 70 65 63 69 66 69 if /patt specifi
2100: 65 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ed.;;
2110: 20 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a .(define (runs:
2120: 72 75 6e 2d 74 65 73 74 73 20 74 61 72 67 65 74 run-tests target
2130: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 70 61 runname test-pa
2140: 74 74 73 20 75 73 65 72 20 66 6c 61 67 73 20 23 tts user flags #
2150: 21 6b 65 79 20 28 72 75 6e 2d 63 6f 75 6e 74 20 !key (run-count
2160: 33 29 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 3)) ;; test-name
2170: 73 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 s. (let* ((keys
2180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2190: 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d keys:config-get-
21a0: 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 fields *configda
21b0: 74 2a 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 20 t*)).. (keyvals
21c0: 20 20 20 20 20 20 20 20 20 20 20 28 6b 65 79 73 (keys
21d0: 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
21e0: 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 keys target))..
21f0: 28 72 75 6e 2d 69 64 20 20 20 20 20 20 20 20 20 (run-id
2200: 20 20 20 20 28 72 6d 74 3a 72 65 67 69 73 74 65 (rmt:registe
2210: 72 2d 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 75 r-run keyvals ru
2220: 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 nname "new" "n/a
2230: 22 20 75 73 65 72 29 29 20 20 3b 3b 20 20 74 65 " user)) ;; te
2240: 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 28 64 65 st-name))).. (de
2250: 66 65 72 72 65 64 20 20 20 20 20 20 20 20 20 20 ferred
2260: 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 '()) ;; delay ru
2270: 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 nning these sinc
2280: 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 e they have a wa
2290: 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 28 72 iton clause.. (r
22a0: 75 6e 63 6f 6e 66 69 67 66 20 20 20 20 20 20 20 unconfigf
22b0: 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 (conc *toppat
22c0: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
22d0: 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 74 65 73 config")).. (tes
22e0: 74 2d 72 65 63 6f 72 64 73 20 20 20 20 20 20 20 t-records
22f0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
2300: 29 29 0a 09 20 3b 3b 20 6e 65 65 64 20 74 6f 20 )).. ;; need to
2310: 70 72 6f 63 65 73 73 20 72 75 6e 63 6f 6e 66 69 process runconfi
2320: 67 73 20 62 65 66 6f 72 65 20 67 65 6e 65 72 61 gs before genera
2330: 74 69 6e 67 20 74 68 65 73 65 20 6c 69 73 74 73 ting these lists
2340: 0a 09 20 28 61 6c 6c 2d 74 65 73 74 73 2d 72 65 .. (all-tests-re
2350: 67 69 73 74 72 79 20 23 66 29 20 20 3b 3b 20 28 gistry #f) ;; (
2360: 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c 29 29 20 tests:get-all))
2370: 3b 3b 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 ;; (tests:get-va
2380: 6c 69 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d lid-tests (make-
2390: 68 61 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 hash-table) test
23a0: 2d 73 65 61 72 63 68 2d 70 61 74 68 29 29 20 3b -search-path)) ;
23b0: 3b 20 61 6c 6c 20 76 61 6c 69 64 20 74 65 73 74 ; all valid test
23c0: 73 20 74 6f 20 63 68 65 63 6b 20 77 61 69 74 6f s to check waito
23d0: 6e 20 6e 61 6d 65 73 0a 09 20 28 61 6c 6c 2d 74 n names.. (all-t
23e0: 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 23 66 est-names #f
23f0: 29 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c ) ;; (hash-tabl
2400: 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 65 73 74 73 e-keys all-tests
2410: 2d 72 65 67 69 73 74 72 79 29 29 0a 09 20 28 74 -registry)).. (t
2420: 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 20 20 est-names
2430: 20 20 23 66 29 20 20 3b 3b 20 28 74 65 73 74 73 #f) ;; (tests
2440: 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d :filter-test-nam
2450: 65 73 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 es all-test-name
2460: 73 20 74 65 73 74 2d 70 61 74 74 73 29 29 0a 09 s test-patts))..
2470: 20 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 (required-tests
2480: 20 20 20 20 20 23 66 29 20 20 3b 3b 28 6c 73 65 #f) ;;(lse
2490: 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 65 t-intersection e
24a0: 71 75 61 6c 3f 20 28 73 74 72 69 6e 67 2d 73 70 qual? (string-sp
24b0: 6c 69 74 20 74 65 73 74 2d 70 61 74 74 73 20 22 lit test-patts "
24c0: 2c 22 29 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ,") test-names))
24d0: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 73 29 ) ;; test-names)
24e0: 29 20 3b 3b 20 41 64 64 65 64 20 74 65 73 74 2d ) ;; Added test-
24f0: 6e 61 6d 65 73 20 61 73 20 69 6e 69 74 69 61 6c names as initial
2500: 20 66 6f 72 20 72 65 71 75 69 72 65 64 2d 74 65 for required-te
2510: 73 74 73 20 62 75 74 20 74 68 61 74 20 66 61 69 sts but that fai
2520: 6c 65 64 20 74 6f 20 77 6f 72 6b 0a 09 20 28 74 led to work.. (t
2530: 61 73 6b 2d 6b 65 79 20 20 20 20 20 20 20 20 20 ask-key
2540: 20 20 28 63 6f 6e 63 20 28 68 61 73 68 2d 74 61 (conc (hash-ta
2550: 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 ble->alist flags
2560: 29 20 22 20 22 20 28 67 65 74 2d 68 6f 73 74 2d ) " " (get-host-
2570: 6e 61 6d 65 29 20 22 20 22 20 28 63 75 72 72 65 name) " " (curre
2580: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 nt-process-id)))
2590: 0a 09 20 28 74 61 73 6b 73 2d 64 62 20 20 20 20 .. (tasks-db
25a0: 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 (tasks:op
25b0: 65 6e 2d 64 62 29 29 29 0a 0a 20 20 20 20 28 73 en-db))).. (s
25c0: 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 et-signal-handle
25d0: 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 0a 09 09 r! signal/int...
25e0: 09 20 28 6c 61 6d 62 64 61 20 28 73 69 67 6e 75 . (lambda (signu
25f0: 6d 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 m).... (let ((
2600: 74 64 62 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d tdb (tasks:open-
2610: 64 62 29 29 29 0a 09 09 09 20 20 20 20 20 28 74 db))).... (t
2620: 61 73 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d 67 asks:set-state-g
2630: 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 74 iven-param-key t
2640: 64 62 20 74 61 73 6b 2d 6b 65 79 20 22 6b 69 6c db task-key "kil
2650: 6c 65 64 22 29 0a 09 09 09 20 20 20 20 20 28 73 led").... (s
2660: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
2670: 20 74 64 62 29 29 0a 09 09 09 20 20 20 28 70 72 tdb)).... (pr
2680: 69 6e 74 20 22 4b 69 6c 6c 65 64 20 62 79 20 73 int "Killed by s
2690: 69 67 69 6e 74 2e 20 45 78 69 74 69 6e 67 22 29 igint. Exiting")
26a0: 0a 09 09 09 20 20 20 28 65 78 69 74 29 29 29 0a .... (exit))).
26b0: 0a 20 20 20 20 3b 3b 20 72 65 67 69 73 74 65 72 . ;; register
26c0: 20 74 68 69 73 20 72 75 6e 20 69 6e 20 6d 6f 6e this run in mon
26d0: 69 74 6f 72 2e 64 62 0a 20 20 20 20 28 74 61 73 itor.db. (tas
26e0: 6b 73 3a 61 64 64 20 74 61 73 6b 73 2d 64 62 20 ks:add tasks-db
26f0: 22 72 75 6e 2d 74 65 73 74 73 22 20 75 73 65 72 "run-tests" user
2700: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
2710: 74 65 73 74 2d 70 61 74 74 73 20 74 61 73 6b 2d test-patts task-
2720: 6b 65 79 29 20 3b 3b 20 70 61 72 61 6d 73 29 0a key) ;; params).
2730: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 (tasks:set-s
2740: 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d tate-given-param
2750: 2d 6b 65 79 20 74 61 73 6b 73 2d 64 62 20 74 61 -key tasks-db ta
2760: 73 6b 2d 6b 65 79 20 22 72 75 6e 6e 69 6e 67 22 sk-key "running"
2770: 29 0a 20 20 20 20 28 72 75 6e 73 3a 73 65 74 2d ). (runs:set-
2780: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
2790: 73 20 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a s run-id inkeys:
27a0: 20 6b 65 79 73 20 69 6e 72 75 6e 6e 61 6d 65 3a keys inrunname:
27b0: 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 runname) ;; the
27c0: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
27d0: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
27e0: 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 28 69 g process. (i
27f0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
2800: 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 runconfigf)..(se
2810: 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 tup-env-defaults
2820: 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d runconfigf run-
2830: 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e id *already-seen
2840: 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a -runconfig-info*
2850: 20 6b 65 79 76 61 6c 73 20 74 61 72 67 65 74 29 keyvals target)
2860: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
2870: 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 "WARNING: You d
2880: 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e o not have a run
2890: 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 config file: "
28a0: 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 0a 20 20 runconfigf))..
28b0: 20 20 3b 3b 20 4e 6f 77 20 67 65 6e 65 72 61 74 ;; Now generat
28c0: 65 20 61 6c 6c 20 74 68 65 20 74 65 73 74 73 20 e all the tests
28d0: 6c 69 73 74 73 0a 20 20 20 20 28 73 65 74 21 20 lists. (set!
28e0: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
28f0: 72 79 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c ry (tests:get-al
2900: 6c 29 29 0a 20 20 20 20 28 73 65 74 21 20 61 6c l)). (set! al
2910: 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 l-test-names
2920: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
2930: 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 s all-tests-regi
2940: 73 74 72 79 29 29 0a 20 20 20 20 28 73 65 74 21 stry)). (set!
2950: 20 74 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 test-names
2960: 20 20 20 20 28 74 65 73 74 73 3a 66 69 6c 74 65 (tests:filte
2970: 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 61 6c 6c r-test-names all
2980: 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 -test-names test
2990: 2d 70 61 74 74 73 29 29 0a 20 20 20 20 28 73 65 -patts)). (se
29a0: 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 t! required-test
29b0: 73 20 20 20 20 20 28 6c 73 65 74 2d 69 6e 74 65 s (lset-inte
29c0: 72 73 65 63 74 69 6f 6e 20 65 71 75 61 6c 3f 20 rsection equal?
29d0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
29e0: 73 74 2d 70 61 74 74 73 20 22 2c 22 29 20 74 65 st-patts ",") te
29f0: 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 0a st-names)). .
2a00: 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 ;; look up a
2a10: 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e ll tests matchin
2a20: 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 61 g the comma sepa
2a30: 72 61 74 65 64 20 6c 69 73 74 20 6f 66 20 67 6c rated list of gl
2a40: 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 65 obs in. ;; te
2a50: 73 74 2d 70 61 74 74 73 20 28 75 73 69 6e 67 20 st-patts (using
2a60: 25 20 61 73 20 77 69 6c 64 63 61 72 64 29 0a 0a % as wildcard)..
2a70: 20 20 20 20 3b 3b 20 28 73 65 74 21 20 74 65 73 ;; (set! tes
2a80: 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 2d t-names (delete-
2a90: 64 75 70 6c 69 63 61 74 65 73 20 28 74 65 73 74 duplicates (test
2aa0: 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 s:get-valid-test
2ab0: 73 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 73 74 s *toppath* test
2ac0: 2d 70 61 74 74 73 29 29 29 0a 20 20 20 20 28 64 -patts))). (d
2ad0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2ae0: 30 20 22 74 65 73 74 73 20 73 65 61 72 63 68 20 0 "tests search
2af0: 70 61 74 68 3a 20 22 20 28 74 65 73 74 73 3a 67 path: " (tests:g
2b00: 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d et-tests-search-
2b10: 70 61 74 68 20 2a 63 6f 6e 66 69 67 64 61 74 2a path *configdat*
2b20: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
2b30: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 6c 6c 20 int-info 0 "all
2b40: 74 65 73 74 73 3a 20 20 22 20 28 73 74 72 69 6e tests: " (strin
2b50: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 73 g-intersperse (s
2b60: 6f 72 74 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d ort all-test-nam
2b70: 65 73 20 73 74 72 69 6e 67 3c 29 20 22 20 22 29 es string<) " ")
2b80: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
2b90: 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 20 nt-info 0 "test
2ba0: 6e 61 6d 65 73 3a 20 22 20 28 73 74 72 69 6e 67 names: " (string
2bb0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 73 6f -intersperse (so
2bc0: 72 74 20 74 65 73 74 2d 6e 61 6d 65 73 20 73 74 rt test-names st
2bd0: 72 69 6e 67 3c 29 20 22 20 22 29 29 0a 0a 20 20 ring<) " "))..
2be0: 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 ;; on the firs
2bf0: 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 t pass or call t
2c00: 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 o run-tests set
2c10: 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 FAILS to NOT_STA
2c20: 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d RTED if. ;; -
2c30: 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 keepgoing is spe
2c40: 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 cified. (if (
2c50: 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 eq? *passnum* 0)
2c60: 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 49 ..(begin.. ;; I
2c70: 73 20 74 68 69 73 20 73 74 69 6c 6c 20 6e 65 63 s this still nec
2c80: 65 73 73 61 72 79 3f 20 49 20 74 68 69 6e 6b 20 essary? I think
2c90: 6e 6f 74 2e 20 55 6e 72 65 61 63 68 61 62 6c 65 not. Unreachable
2ca0: 20 74 65 73 74 73 20 61 72 65 20 6d 61 72 6b 65 tests are marke
2cb0: 64 20 61 73 20 73 75 63 68 20 61 6e 64 20 0a 09 d as such and ..
2cc0: 20 20 3b 3b 20 73 68 6f 75 6c 64 20 6e 6f 74 20 ;; should not
2cd0: 63 61 75 73 65 20 70 72 6f 62 6c 65 6d 73 20 68 cause problems h
2ce0: 65 72 65 2e 0a 09 20 20 3b 3b 0a 09 20 20 3b 3b ere... ;;.. ;;
2cf0: 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 have to delete
2d00: 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 test records whe
2d10: 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 re NOT_STARTED s
2d20: 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 ince they can ca
2d30: 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 use -keepgoing t
2d40: 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 o .. ;; get stu
2d50: 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 ck due to becomi
2d60: 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 ng inaccessible
2d70: 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 from a failed te
2d80: 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 st. I.e. if test
2d90: 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b B depends .. ;
2da0: 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 ; on test A but
2db0: 74 65 73 74 20 42 20 72 65 61 63 68 65 64 20 74 test B reached t
2dc0: 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e he point on bein
2dd0: 67 20 72 65 67 69 73 74 65 72 65 64 20 61 73 20 g registered as
2de0: 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 NOT_STARTED and
2df0: 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 test.. ;; A fai
2e00: 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 led for some rea
2e10: 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 son then on re-r
2e20: 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f un using -keepgo
2e30: 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 ing the run can
2e40: 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a never complete..
2e50: 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 28 72 6d 74 . ;;.. ;; (rmt
2e60: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 64 :general-call 'd
2e70: 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 elete-tests-in-s
2e80: 74 61 74 65 20 72 75 6e 2d 69 64 20 22 4e 4f 54 tate run-id "NOT
2e90: 5f 53 54 41 52 54 45 44 22 29 0a 09 20 20 0a 09 _STARTED").. ..
2ea0: 20 20 3b 3b 20 4e 6f 77 20 63 6f 6e 76 65 72 74 ;; Now convert
2eb0: 20 46 41 49 4c 20 61 6e 64 20 61 6e 79 74 68 69 FAIL and anythi
2ec0: 6e 67 20 69 6e 20 61 6c 6c 6f 77 2d 61 75 74 6f ng in allow-auto
2ed0: 2d 72 65 72 75 6e 20 74 6f 20 4e 4f 54 5f 53 54 -rerun to NOT_ST
2ee0: 41 52 54 45 44 0a 09 20 20 3b 3b 0a 09 20 20 28 ARTED.. ;;.. (
2ef0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
2f00: 20 28 73 74 61 74 65 29 0a 09 09 20 20 20 20 20 (state)...
2f10: 20 28 72 6d 74 3a 73 65 74 2d 74 65 73 74 73 2d (rmt:set-tests-
2f20: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
2f30: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 73 -id test-names s
2f40: 74 61 74 65 20 23 66 20 22 4e 4f 54 5f 53 54 41 tate #f "NOT_STA
2f50: 52 54 45 44 22 20 73 74 61 74 65 29 29 0a 09 09 RTED" state))...
2f60: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 (string-spli
2f70: 74 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c t (or (configf:l
2f80: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
2f90: 2a 20 22 73 65 74 75 70 22 20 22 61 6c 6c 6f 77 * "setup" "allow
2fa0: 2d 61 75 74 6f 2d 72 65 72 75 6e 22 29 20 22 22 -auto-rerun") ""
2fb0: 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 45 6e ))))).. ;; En
2fc0: 73 75 72 65 20 61 6c 6c 20 74 65 73 74 73 20 61 sure all tests a
2fd0: 72 65 20 72 65 67 69 73 74 65 72 65 64 20 69 6e re registered in
2fe0: 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 the test_meta t
2ff0: 61 62 6c 65 0a 20 20 20 20 28 72 75 6e 73 3a 75 able. (runs:u
3000: 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d pdate-all-test_m
3010: 65 74 61 20 23 66 29 0a 0a 20 20 20 20 3b 3b 20 eta #f).. ;;
3020: 6e 6f 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 65 now add non-dire
3030: 63 74 6c 79 20 72 65 66 65 72 65 6e 63 65 64 20 ctly referenced
3040: 64 65 70 65 6e 64 65 6e 63 69 65 73 20 28 69 2e dependencies (i.
3050: 65 2e 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 3b e. waiton). ;
3060: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30a0: 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 72 =======. ;; r
30b0: 65 66 61 63 74 6f 72 69 6e 67 20 74 68 69 73 20 efactoring this
30c0: 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 block into tests
30d0: 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 0a 20 :get-full-data.
30e0: 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 57 68 61 ;;. ;; Wha
30f0: 74 20 68 61 70 70 65 6e 64 65 64 2c 20 74 68 69 t happended, thi
3100: 73 20 63 6f 64 65 20 69 73 20 6e 6f 77 20 64 75 s code is now du
3110: 70 6c 69 63 61 74 65 64 20 69 6e 20 74 65 73 74 plicated in test
3120: 73 21 3f 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b s!?. ;;. ;
3130: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3170: 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 28 69 66 20 =======. (if
3180: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
3190: 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c -names))..(let l
31a0: 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 oop ((hed (car t
31b0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 est-names))...
31c0: 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d (tal (cdr test-
31d0: 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 names)))
31e0: 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 ;; 'return-proc
31f0: 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 s tells the conf
3200: 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 ig reader to pre
3210: 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d p running system
3220: 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 but return a pr
3230: 6f 63 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 69 oc.. (change-di
3240: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
3250: 2a 29 20 3b 3b 20 50 4c 45 41 53 45 20 4f 50 54 *) ;; PLEASE OPT
3260: 49 4d 49 5a 45 20 4d 45 21 21 21 20 49 20 74 68 IMIZE ME!!! I th
3270: 69 6e 6b 20 74 68 69 73 20 73 68 6f 75 6c 64 20 ink this should
3280: 62 65 20 61 20 6e 6f 2d 6f 70 20 62 75 74 20 74 be a no-op but t
3290: 68 65 72 65 20 61 72 65 20 73 65 76 65 72 61 6c here are several
32a0: 20 70 6c 61 63 65 73 20 77 68 65 72 65 20 63 68 places where ch
32b0: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 69 65 73 ange-directories
32c0: 20 63 6f 75 6c 64 20 62 65 20 68 61 70 70 65 6e could be happen
32d0: 69 6e 67 2e 0a 09 20 20 28 73 65 74 65 6e 76 20 ing... (setenv
32e0: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 68 "MT_TEST_NAME" h
32f0: 65 64 29 20 3b 3b 20 0a 09 20 20 28 6c 65 74 2a ed) ;; .. (let*
3300: 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 ((config (test
3310: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
3320: 20 68 65 64 20 61 6c 6c 2d 74 65 73 74 73 2d 72 hed all-tests-r
3330: 65 67 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d egistry 'return-
3340: 70 72 6f 63 73 29 29 0a 09 09 20 28 77 61 69 74 procs))... (wait
3350: 6f 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 ons (let ((instr
3360: 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 (if config ....
3370: 09 09 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f .. (config-loo
3380: 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 kup config "requ
3390: 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f irements" "waito
33a0: 6e 22 29 0a 09 09 09 09 09 20 20 20 28 62 65 67 n")...... (beg
33b0: 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 in ;; No config
33c0: 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 means this is a
33d0: 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 non-existant tes
33e0: 74 0a 09 09 09 09 09 20 20 20 20 20 28 64 65 62 t...... (deb
33f0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
3400: 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 R: non-existent
3410: 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 required test \"
3420: 22 20 68 65 64 20 22 5c 22 22 29 0a 09 09 09 09 " hed "\"").....
3430: 09 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 . (exit 1)))
3440: 29 29 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 )).... (debug
3450: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 :print-info 8 "w
3460: 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 aitons string is
3470: 20 22 20 69 6e 73 74 72 29 0a 09 09 09 20 20 20 " instr)....
3480: 20 28 6c 65 74 20 28 28 6e 65 77 77 61 69 74 6f (let ((newwaito
3490: 6e 73 0a 09 09 09 09 20 20 20 28 73 74 72 69 6e ns..... (strin
34a0: 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 g-split (cond...
34b0: 09 09 09 09 20 20 28 28 70 72 6f 63 65 64 75 72 .... ((procedur
34c0: 65 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 09 e? instr).......
34d0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 (let ((res (i
34e0: 6e 73 74 72 29 29 29 0a 09 09 09 09 09 09 20 20 nstr))).......
34f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3500: 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 70 info 8 "waiton p
3510: 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 rocedure results
3520: 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 in string " res
3530: 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 " for test " he
3540: 64 29 0a 09 09 09 09 09 09 20 20 20 20 20 72 65 d)....... re
3550: 73 29 29 0a 09 09 09 09 09 09 20 20 28 28 73 74 s))....... ((st
3560: 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 ring? instr)
3570: 20 69 6e 73 74 72 29 0a 09 09 09 09 09 09 20 20 instr).......
3580: 28 65 6c 73 65 20 0a 09 09 09 09 09 09 20 20 20 (else .......
3590: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 ;; NOTE: This is
35a0: 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 actually the ca
35b0: 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f se of *no* waito
35c0: 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ns! ;; (debug:pr
35d0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 73 6f int 0 "ERROR: so
35e0: 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f mething went wro
35f0: 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 ng in processing
3600: 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 waitons for tes
3610: 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 09 20 t " hed).......
3620: 20 20 22 22 29 29 29 29 29 0a 09 09 09 20 20 20 "")))))....
3630: 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 (filter (lamb
3640: 64 61 20 28 78 29 0a 09 09 09 09 09 28 69 66 20 da (x)......(if
3650: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
3660: 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 default all-test
3670: 73 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 29 s-registry x #f)
3680: 0a 09 09 09 09 09 20 20 20 20 23 74 0a 09 09 09 ...... #t....
3690: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
36a0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
36b0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 rint 0 "ERROR: t
36c0: 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 est " hed " has
36d0: 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 unrecognised wai
36e0: 74 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 ton testname " x
36f0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 29 )...... #f)
3700: 29 29 0a 09 09 09 09 20 20 20 20 20 20 6e 65 77 ))..... new
3710: 77 61 69 74 6f 6e 73 29 29 29 29 29 0a 09 20 20 waitons)))))..
3720: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3730: 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 3a 20 nfo 8 "waitons:
3740: 22 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 " waitons)..
3750: 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 ;; check for hed
3760: 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 in waitons => t
3770: 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 his would be cir
3780: 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 cular, remove it
3790: 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 20 and issue an..
37a0: 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 20 ;; error..
37b0: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 (if (member hed
37c0: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 waitons)...(beg
37d0: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
37e0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
37f0: 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 6c st " hed " has l
3800: 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 isted itself as
3810: 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 a waiton, please
3820: 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 correct this!")
3830: 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 74 6f ... (set! waito
3840: 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ns (filter (lamb
3850: 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 da (x)(not (equa
3860: 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 74 l? x hed))) wait
3870: 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 0a 09 20 ons)))).. ..
3880: 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 ;; (items (
3890: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
38a0: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
38b0: 69 67 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 ig))).. (if (
38c0: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
38d0: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
38e0: 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 -records hed #f)
38f0: 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d )...(hash-table-
3900: 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 set! test-record
3910: 73 0a 09 09 09 09 20 68 65 64 20 28 76 65 63 74 s..... hed (vect
3920: 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 0a or hed ;; 0.
3930: 09 09 09 09 09 20 20 20 20 20 63 6f 6e 66 69 67 ..... config
3940: 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 20 20 20 ;; 1......
3950: 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 waitons ;; 2...
3960: 09 09 09 20 20 20 20 20 28 63 6f 6e 66 69 67 2d ... (config-
3970: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
3980: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 equirements" "pr
3990: 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 iority") ;;
39a0: 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 priority 3......
39b0: 20 20 20 20 20 28 6c 65 74 20 28 28 69 74 65 6d (let ((item
39c0: 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
39d0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
39e0: 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 onfig "items" #f
39f0: 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 )) ;; items 4...
3a00: 09 09 09 09 20 20 20 28 69 74 65 6d 73 74 61 62 .... (itemstab
3a10: 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 le (hash-table-r
3a20: 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 ef/default confi
3a30: 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 g "itemstable" #
3a40: 66 29 29 29 20 0a 09 09 09 09 09 20 20 20 20 20 f))) ......
3a50: 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 ;; if either i
3a60: 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 tems or items ta
3a70: 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 ble is a proc re
3a80: 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 turn it so test
3a90: 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 20 20 20 running......
3aa0: 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 ;; process c
3ab0: 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 an know to call
3ac0: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
3ad0: 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 from-config.....
3ae0: 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 . ;; if ei
3af0: 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 ther is a list a
3b00: 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f nd none is a pro
3b10: 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 c go ahead and c
3b20: 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 all get-items...
3b30: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6f 74 68 ... ;; oth
3b40: 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 erwise return #f
3b50: 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 - this is not a
3b60: 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a n iterated test.
3b70: 09 09 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e ..... (con
3b80: 64 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 d.......((proced
3b90: 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 ure? items)
3ba0: 20 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a ....... (debug:
3bb0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 print-info 4 "it
3bc0: 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 ems is a procedu
3bd0: 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
3be0: 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 ter")....... ite
3bf0: 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b ms) ;
3c00: 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 ; calc later....
3c10: 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
3c20: 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
3c30: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
3c40: 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 74 61 62 info 4 "itemstab
3c50: 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 le is a procedur
3c60: 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
3c70: 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 6d er")....... item
3c80: 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b stable) ;;
3c90: 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 calc later.....
3ca0: 09 09 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ..((filter (lamb
3cb0: 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 da (x)........
3cc0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 (let ((val (car
3cd0: 20 78 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 x)))........
3ce0: 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 (if (procedure
3cf0: 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 ? val) val #f)))
3d00: 0a 09 09 09 09 09 09 09 20 28 61 70 70 65 6e 64 ........ (append
3d10: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
3d20: 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 s) items '())...
3d30: 09 09 09 09 09 09 20 28 69 66 20 28 6c 69 73 74 ...... (if (list
3d40: 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 ? itemstable) it
3d50: 65 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a emstable '()))).
3d60: 09 09 09 09 09 09 20 27 68 61 76 65 2d 70 72 6f ...... 'have-pro
3d70: 63 65 64 75 72 65 29 0a 09 09 09 09 09 09 28 28 cedure).......((
3d80: 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 or (list? items)
3d90: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
3da0: 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a e)) ;; calc now.
3db0: 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
3dc0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d int-info 4 "item
3dd0: 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 s and itemstable
3de0: 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 are lists, calc
3df0: 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 09 now\n".........
3e00: 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 " items: "
3e10: 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 items " itemsta
3e20: 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c ble: " itemstabl
3e30: 65 29 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 e)....... (items
3e40: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
3e50: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a config config)).
3e60: 09 09 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 ......(else #f))
3e70: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3e80: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e ;; n
3e90: 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 ot iterated.....
3ea0: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
3eb0: 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 itemsdat 5.....
3ec0: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
3ed0: 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f spare - used fo
3ee0: 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 r item-path.....
3ef0: 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 . ))).. (
3f00: 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 for-each ..
3f10: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
3f20: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e .. (if (an
3f30: 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d d waiton (not (m
3f40: 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 ember waiton tes
3f50: 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 t-names)))...
3f60: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 (begin... (s
3f70: 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 et! required-tes
3f80: 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 ts (cons waiton
3f90: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
3fa0: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 74 65 ... (set! te
3fb0: 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 st-names (cons w
3fc0: 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
3fd0: 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 ))))) ;; was an
3fe0: 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f append, now a co
3ff0: 6e 73 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 ns.. waitons
4000: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 ).. (let ((re
4010: 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 mtests (delete-d
4020: 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e uplicates (appen
4030: 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 d waitons tal)))
4040: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ).. (if (no
4050: 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 t (null? remtest
4060: 73 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 s))... (loop (c
4070: 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 ar remtests)(cdr
4080: 20 72 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 remtests)))))))
4090: 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
40a0: 6e 75 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 null? required-t
40b0: 65 73 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 ests))..(debug:p
40c0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 rint-info 1 "Add
40d0: 69 6e 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 ing " required-t
40e0: 65 73 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 ests " to the ru
40f0: 6e 20 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b n queue")). ;
4100: 3b 20 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 ; NOTE: these ar
4110: 65 20 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 e all parent tes
4120: 74 73 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f ts, items are no
4130: 74 20 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a t expanded yet..
4140: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4150: 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 72 65 -info 4 "test-re
4160: 63 6f 72 64 73 3d 22 20 28 68 61 73 68 2d 74 61 cords=" (hash-ta
4170: 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d ble->alist test-
4180: 72 65 63 6f 72 64 73 29 29 0a 20 20 20 20 28 6c records)). (l
4190: 65 74 20 28 28 72 65 67 6c 65 6e 20 28 63 6f 6e et ((reglen (con
41a0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
41b0: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
41c0: 22 72 75 6e 71 75 65 75 65 22 29 29 29 0a 20 20 "runqueue"))).
41d0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
41e0: 74 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b th (hash-table-k
41f0: 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 eys test-records
4200: 29 29 20 30 29 0a 09 20 20 28 62 65 67 69 6e 0a )) 0).. (begin.
4210: 09 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 . (runs:run-t
4220: 65 73 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 ests-queue run-i
4230: 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 d runname test-r
4240: 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 73 20 66 ecords keyvals f
4250: 6c 61 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 lags test-patts
4260: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 required-tests (
4270: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 72 65 67 6c any->number regl
4280: 65 6e 29 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 en) all-tests-re
4290: 67 69 73 74 72 79 29 0a 09 20 20 20 20 3b 3b 20 gistry).. ;;
42a0: 69 66 20 72 75 6e 2d 63 6f 75 6e 74 20 3e 20 30 if run-count > 0
42b0: 20 63 61 6c 6c 2c 20 73 65 74 20 2d 70 72 65 63 call, set -prec
42c0: 6c 65 61 6e 20 61 6e 64 20 2d 72 65 72 75 6e 20 lean and -rerun
42d0: 53 54 55 43 4b 2f 44 45 41 44 0a 09 20 20 20 20 STUCK/DEAD..
42e0: 28 69 66 20 28 3e 20 72 75 6e 2d 63 6f 75 6e 74 (if (> run-count
42f0: 20 30 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 0)...(begin...
4300: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
4310: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4320: 74 20 66 6c 61 67 73 20 22 2d 70 72 65 63 6c 65 t flags "-precle
4330: 61 6e 22 20 23 66 29 29 0a 09 09 20 20 20 20 20 an" #f))...
4340: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
4350: 21 20 66 6c 61 67 73 20 22 2d 70 72 65 63 6c 65 ! flags "-precle
4360: 61 6e 22 20 23 74 29 29 0a 09 09 20 20 28 69 66 an" #t))... (if
4370: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
4380: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
4390: 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 ags "-rerun" #f)
43a0: 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 2d )... (hash-
43b0: 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 table-set! flags
43c0: 20 22 2d 72 65 72 75 6e 22 20 22 53 54 55 43 4b "-rerun" "STUCK
43d0: 2f 44 45 41 44 2c 6e 2f 61 2c 5a 45 52 4f 5f 49 /DEAD,n/a,ZERO_I
43e0: 54 45 4d 53 22 29 29 0a 09 09 20 20 28 72 75 6e TEMS"))... (run
43f0: 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 61 72 67 s:run-tests targ
4400: 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d et runname test-
4410: 70 61 74 74 73 20 75 73 65 72 20 66 6c 61 67 73 patts user flags
4420: 20 72 75 6e 2d 63 6f 75 6e 74 3a 20 28 2d 20 72 run-count: (- r
4430: 75 6e 2d 63 6f 75 6e 74 20 31 29 29 29 29 29 0a un-count 1))))).
4440: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
4450: 69 6e 66 6f 20 30 20 22 4e 6f 20 74 65 73 74 73 info 0 "No tests
4460: 20 74 6f 20 72 75 6e 22 29 29 29 0a 20 20 20 20 to run"))).
4470: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4480: 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 62 79 o 4 "All done by
4490: 20 68 65 72 65 22 29 0a 20 20 20 20 28 74 61 73 here"). (tas
44a0: 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d 67 69 76 ks:set-state-giv
44b0: 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 74 61 73 en-param-key tas
44c0: 6b 73 2d 64 62 20 74 61 73 6b 2d 6b 65 79 20 22 ks-db task-key "
44d0: 64 6f 6e 65 22 29 0a 20 20 20 20 28 73 71 6c 69 done"). (sqli
44e0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 74 61 te3:finalize! ta
44f0: 73 6b 73 2d 64 62 29 29 29 0a 0a 0a 3b 3b 20 6c sks-db)))...;; l
4500: 6f 6f 70 20 6c 6f 67 69 63 2e 20 54 68 65 73 65 oop logic. These
4510: 20 61 72 65 20 75 73 65 64 20 69 6e 20 72 75 6e are used in run
4520: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
4530: 65 20 74 6f 20 6d 61 6b 65 20 69 74 20 61 20 62 e to make it a b
4540: 69 74 20 6d 6f 72 65 20 72 65 61 64 61 62 6c 65 it more readable
4550: 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 72 65 67 20 6e ..;;.;; If reg n
4560: 6f 74 20 66 75 6c 6c 20 61 6e 64 20 68 61 76 65 ot full and have
4570: 20 69 74 65 6d 73 20 69 6e 20 74 61 6c 20 74 68 items in tal th
4580: 65 6e 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 en loop with (ca
4590: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
45a0: 72 65 67 20 72 65 72 75 6e 73 0a 3b 3b 20 49 66 reg reruns.;; If
45b0: 20 72 65 67 20 69 73 20 66 75 6c 6c 20 28 69 2e reg is full (i.
45c0: 65 2e 20 6c 65 6e 67 74 68 20 3e 3d 20 6e 0a 3b e. length >= n.;
45d0: 3b 20 20 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 ; loop with (c
45e0: 61 72 20 72 65 67 29 20 74 61 6c 20 28 63 64 72 ar reg) tal (cdr
45f0: 20 72 65 67 29 20 72 65 72 75 6e 73 0a 3b 3b 20 reg) reruns.;;
4600: 49 66 20 74 61 6c 20 69 73 20 65 6d 70 74 79 0a If tal is empty.
4610: 3b 3b 20 20 20 62 75 74 20 68 61 76 65 20 69 74 ;; but have it
4620: 65 6d 73 20 69 6e 20 72 65 67 3b 20 6c 6f 6f 70 ems in reg; loop
4630: 20 77 69 74 68 20 28 63 61 72 20 72 65 67 29 28 with (car reg)(
4640: 63 64 72 20 72 65 67 29 20 27 28 29 20 72 65 72 cdr reg) '() rer
4650: 75 6e 73 0a 3b 3b 20 20 20 49 66 20 72 65 67 20 uns.;; If reg
4660: 69 73 20 65 6d 70 74 79 20 3d 3e 20 61 6c 6c 20 is empty => all
4670: 64 6f 6e 65 0a 0a 28 64 65 66 69 6e 65 20 28 72 done..(define (r
4680: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
4690: 65 64 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 ed tal reg n reg
46a0: 66 75 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 full). (if regf
46b0: 75 6c 6c 0a 20 20 20 20 20 20 28 63 61 72 20 72 ull. (car r
46c0: 65 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e eg). (if (n
46d0: 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 74 61 6c ull? tal) ;; tal
46e0: 20 69 73 20 75 73 65 64 20 75 70 2c 20 70 6f 70 is used up, pop
46f0: 20 66 72 6f 6d 20 72 65 67 0a 09 20 20 28 63 61 from reg.. (ca
4700: 72 20 72 65 67 29 0a 09 20 20 28 63 61 72 20 74 r reg).. (car t
4710: 61 6c 29 29 29 29 0a 0a 3b 3b 20 20 20 28 63 6f al))))..;; (co
4720: 6e 64 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 72 nd.;; ((and r
4730: 65 67 66 75 6c 6c 20 28 6e 75 6c 6c 3f 20 72 65 egfull (null? re
4740: 67 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 g)(not (null? ta
4750: 6c 29 29 29 20 20 20 20 20 20 28 63 61 72 20 74 l))) (car t
4760: 61 6c 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 al)).;; ((and
4770: 20 72 65 67 66 75 6c 6c 20 28 6e 6f 74 20 28 6e regfull (not (n
4780: 75 6c 6c 3f 20 72 65 67 29 29 29 20 20 20 20 20 ull? reg)))
4790: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 (car
47a0: 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 61 reg)).;; ((a
47b0: 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c 29 nd (not regfull)
47c0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 6f 74 20 (null? tal)(not
47d0: 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 20 28 63 (null? reg))) (c
47e0: 61 72 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 ar reg)).;; (
47f0: 28 61 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 6c (and (not regful
4800: 6c 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 l)(not (null? ta
4810: 6c 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 l)))
4820: 28 63 61 72 20 74 61 6c 29 29 0a 3b 3b 20 20 20 (car tal)).;;
4830: 20 28 65 6c 73 65 0a 3b 3b 20 20 20 20 20 28 64 (else.;; (d
4840: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
4850: 52 4f 52 3a 20 72 75 6e 73 3a 71 75 65 75 65 2d ROR: runs:queue-
4860: 6e 65 78 74 2d 68 65 64 2c 20 74 61 6c 3d 22 20 next-hed, tal="
4870: 74 61 6c 20 22 2c 20 72 65 67 3d 22 20 72 65 67 tal ", reg=" reg
4880: 20 22 2c 20 6e 3d 22 20 6e 20 22 2c 20 72 65 67 ", n=" n ", reg
4890: 66 75 6c 6c 3d 22 20 72 65 67 66 75 6c 6c 29 0a full=" regfull).
48a0: 3b 3b 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 ;; #f)))..(d
48b0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 efine (runs:queu
48c0: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
48d0: 65 67 20 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 eg n regfull).
48e0: 28 69 66 20 72 65 67 66 75 6c 6c 0a 20 20 20 20 (if regfull.
48f0: 20 20 74 61 6c 0a 20 20 20 20 20 20 28 69 66 20 tal. (if
4900: 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 6d (null? tal) ;; m
4910: 75 73 74 20 74 72 61 6e 73 66 65 72 20 66 72 6f ust transfer fro
4920: 6d 20 72 65 67 0a 09 20 20 28 63 64 72 20 72 65 m reg.. (cdr re
4930: 67 29 0a 09 20 20 28 63 64 72 20 74 61 6c 29 29 g).. (cdr tal))
4940: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
4950: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
4960: 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 tal reg n regfu
4970: 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c ll). (if regful
4980: 6c 0a 20 20 20 20 20 20 28 63 64 72 20 72 65 67 l. (cdr reg
4990: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c ). (if (nul
49a0: 6c 3f 20 74 61 6c 29 20 3b 3b 20 69 66 20 74 61 l? tal) ;; if ta
49b0: 6c 20 69 73 20 6e 75 6c 6c 20 61 6e 64 20 72 65 l is null and re
49c0: 67 20 6e 6f 74 20 66 75 6c 6c 20 74 68 65 6e 20 g not full then
49d0: 27 28 29 20 61 73 20 72 65 67 20 63 6f 6e 74 65 '() as reg conte
49e0: 6e 74 73 20 6d 6f 76 65 64 20 74 6f 20 74 61 6c nts moved to tal
49f0: 0a 09 20 20 27 28 29 0a 09 20 20 72 65 67 29 29 .. '().. reg))
4a00: 29 0a 0a 28 64 65 66 69 6e 65 20 72 75 6e 73 3a )..(define runs:
4a10: 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d nothing-left-in-
4a20: 71 75 65 75 65 2d 63 6f 75 6e 74 20 30 29 0a 0a queue-count 0)..
4a30: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 65 78 (define (runs:ex
4a40: 70 61 6e 64 2d 69 74 65 6d 73 20 68 65 64 20 74 pand-items hed t
4a50: 61 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 al reg reruns re
4a60: 67 66 75 6c 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 gfull newtal job
4a70: 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 group max-concur
4a80: 72 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 rent-jobs run-id
4a90: 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 waitons item-pa
4aa0: 74 68 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 th testmode test
4ab0: 2d 72 65 63 6f 72 64 20 63 61 6e 2d 72 75 6e 2d -record can-run-
4ac0: 6d 6f 72 65 20 69 74 65 6d 73 20 72 75 6e 6e 61 more items runna
4ad0: 6d 65 20 74 63 6f 6e 66 69 67 20 72 65 67 6c 65 me tconfig regle
4ae0: 6e 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 n test-registry
4af0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 74 65 test-records ite
4b00: 6d 6d 61 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 mmap). (let* ((
4b10: 6c 6f 6f 70 2d 6c 69 73 74 20 20 20 20 20 20 20 loop-list
4b20: 28 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 (list hed tal re
4b30: 67 20 72 65 72 75 6e 73 29 29 0a 09 20 28 70 72 g reruns)).. (pr
4b40: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 72 ereqs-not-met (r
4b50: 6d 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e mt:get-prereqs-n
4b60: 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 ot-met run-id wa
4b70: 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 itons item-path
4b80: 74 65 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 70 testmode itemmap
4b90: 3a 20 69 74 65 6d 6d 61 70 29 29 0a 09 20 3b 3b : itemmap)).. ;;
4ba0: 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 (prereqs-not-me
4bb0: 74 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 t (mt:lazy-get-p
4bc0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 rereqs-not-met r
4bd0: 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 un-id waitons it
4be0: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 em-path mode: te
4bf0: 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 70 3a 20 stmode itemmap:
4c00: 69 74 65 6d 6d 61 70 29 29 0a 09 20 28 66 61 69 itemmap)).. (fai
4c10: 6c 73 20 20 20 20 20 20 20 20 20 20 20 28 72 75 ls (ru
4c20: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
4c30: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
4c40: 09 20 28 70 72 65 72 65 71 2d 66 61 69 6c 73 20 . (prereq-fails
4c50: 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 70 72 (runs:calc-pr
4c60: 65 72 65 71 2d 66 61 69 6c 20 70 72 65 72 65 71 ereq-fail prereq
4c70: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 6e s-not-met)).. (n
4c80: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 on-completed (
4c90: 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f runs:calc-not-co
4ca0: 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d mpleted prereqs-
4cb0: 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 72 75 6e not-met)).. (run
4cc0: 6e 61 62 6c 65 73 20 20 20 20 20 20 20 28 72 75 nables (ru
4cd0: 6e 73 3a 63 61 6c 63 2d 72 75 6e 6e 61 62 6c 65 ns:calc-runnable
4ce0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
4cf0: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
4d00: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 53 54 41 rint-info 4 "STA
4d10: 52 54 20 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 RT OF INNER COND
4d20: 20 23 32 20 22 0a 09 09 20 20 20 20 20 20 22 5c #2 "... "\
4d30: 6e 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 n can-run-more:
4d40: 20 20 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 " can-run-mor
4d50: 65 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 74 65 e... "\n te
4d60: 73 74 6e 61 6d 65 3a 20 20 20 20 20 20 20 20 22 stname: "
4d70: 20 68 65 64 0a 09 09 20 20 20 20 20 20 22 5c 6e hed... "\n
4d80: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
4d90: 3a 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 : " (runs:pretty
4da0: 2d 73 74 72 69 6e 67 20 70 72 65 72 65 71 73 2d -string prereqs-
4db0: 6e 6f 74 2d 6d 65 74 29 0a 09 09 20 20 20 20 20 not-met)...
4dc0: 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 "\n non-complet
4dd0: 65 64 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 72 ed: " (runs:pr
4de0: 65 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d etty-string non-
4df0: 63 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 20 20 completed) ...
4e00: 20 20 20 20 22 5c 6e 20 70 72 65 72 65 71 2d 66 "\n prereq-f
4e10: 61 69 6c 73 3a 20 20 20 20 22 20 28 72 75 6e 73 ails: " (runs
4e20: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 :pretty-string p
4e30: 72 65 72 65 71 2d 66 61 69 6c 73 29 0a 09 09 20 rereq-fails)...
4e40: 20 20 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 "\n fails:
4e50: 20 20 20 20 20 20 20 20 20 20 22 20 28 72 75 6e " (run
4e60: 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 s:pretty-string
4e70: 66 61 69 6c 73 29 0a 09 09 20 20 20 20 20 20 22 fails)... "
4e80: 5c 6e 20 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 \n testmode:
4e90: 20 20 20 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 " testmode..
4ea0: 09 20 20 20 20 20 20 22 5c 6e 20 28 6d 65 6d 62 . "\n (memb
4eb0: 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 er 'toplevel tes
4ec0: 74 6d 6f 64 65 29 3a 20 22 20 28 6d 65 6d 62 65 tmode): " (membe
4ed0: 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 r 'toplevel test
4ee0: 6d 6f 64 65 29 0a 09 09 20 20 20 20 20 20 22 5c mode)... "\
4ef0: 6e 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d n (null? non-com
4f00: 70 6c 65 74 65 64 29 3a 20 20 20 20 22 20 28 6e pleted): " (n
4f10: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
4f20: 65 64 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 ed)... "\n
4f30: 72 65 72 75 6e 73 3a 20 20 20 20 20 20 20 20 20 reruns:
4f40: 20 22 20 72 65 72 75 6e 73 0a 09 09 20 20 20 20 " reruns...
4f50: 20 20 22 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 "\n items:
4f60: 20 20 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 " items..
4f70: 09 20 20 20 20 20 20 22 5c 6e 20 63 61 6e 2d 72 . "\n can-r
4f80: 75 6e 2d 6d 6f 72 65 3a 20 20 20 20 22 20 63 61 un-more: " ca
4f90: 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a 0a 20 20 20 n-run-more)..
4fa0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 3b 3b 20 61 (cond. ;; a
4fb0: 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 74 2c 20 ll prereqs met,
4fc0: 66 69 72 65 20 6f 66 66 20 74 68 65 20 74 65 73 fire off the tes
4fd0: 74 0a 20 20 20 20 20 3b 3b 20 6f 72 2c 20 69 66 t. ;; or, if
4fe0: 20 69 74 20 69 73 20 61 20 27 74 6f 70 6c 65 76 it is a 'toplev
4ff0: 65 6c 20 74 65 73 74 20 61 6e 64 20 61 6c 6c 20 el test and all
5000: 70 72 65 72 65 71 73 20 6e 6f 74 20 6d 65 74 20 prereqs not met
5010: 61 72 65 20 43 4f 4d 50 4c 45 54 45 44 20 74 68 are COMPLETED th
5020: 65 6e 20 6c 61 75 6e 63 68 0a 0a 20 20 20 20 20 en launch..
5030: 28 28 61 6e 64 20 28 6e 6f 74 20 28 6d 65 6d 62 ((and (not (memb
5040: 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 er 'toplevel tes
5050: 74 6d 6f 64 65 29 29 0a 09 20 20 20 28 6d 65 6d tmode)).. (mem
5060: 62 65 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ber (hash-table-
5070: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
5080: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
5090: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
50a0: 61 6d 65 20 68 65 64 20 69 74 65 6d 2d 70 61 74 ame hed item-pat
50b0: 68 29 20 27 6e 2f 61 29 0a 09 09 20 20 20 27 28 h) 'n/a)... '(
50c0: 44 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f 76 65 64 DONOTRUN removed
50d0: 20 43 41 4e 4e 4f 54 52 55 4e 29 29 29 20 3b 3b CANNOTRUN))) ;;
50e0: 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 *common:cant-ru
50f0: 6e 2d 73 74 61 74 65 73 2d 73 79 6d 2a 29 20 3b n-states-sym*) ;
5100: 3b 20 27 28 43 4f 4d 50 4c 45 54 45 44 20 4b 49 ; '(COMPLETED KI
5110: 4c 4c 45 44 20 57 41 49 56 45 44 20 55 4e 4b 4e LLED WAIVED UNKN
5120: 4f 57 4e 20 49 4e 43 4f 4d 50 4c 45 54 45 29 29 OWN INCOMPLETE))
5130: 20 3b 3b 20 74 72 79 20 74 6f 20 63 61 74 63 68 ;; try to catch
5140: 20 72 65 70 65 61 74 20 70 72 6f 63 65 73 73 69 repeat processi
5150: 6e 67 20 6f 66 20 43 4f 4d 50 4c 45 54 45 44 20 ng of COMPLETED
5160: 74 65 73 74 73 20 68 65 72 65 0a 20 20 20 20 20 tests here.
5170: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5180: 66 6f 20 31 20 22 54 65 73 74 20 22 20 68 65 64 fo 1 "Test " hed
5190: 20 22 20 73 65 74 20 74 6f 20 5c 22 22 20 28 68 " set to \"" (h
51a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
51b0: 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e st-registry (run
51c0: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
51d0: 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 6d 2d 70 -name hed item-p
51e0: 61 74 68 29 29 20 22 5c 22 2e 20 52 65 6d 6f 76 ath)) "\". Remov
51f0: 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 68 65 20 ing it from the
5200: 71 75 65 75 65 22 29 0a 20 20 20 20 20 20 28 69 queue"). (i
5210: 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
5220: 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 28 ? tal)).. (
5230: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 not (null? reg))
5240: 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e 73 ).. (list (runs
5250: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
5260: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
5270: 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a egfull)...(runs:
5280: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
5290: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
52a0: 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 gfull)...(runs:q
52b0: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 ueue-next-reg ta
52c0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
52d0: 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 0a full)...reruns).
52e0: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 . (begin.. (
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 74 68 69 6e 67 20 6c 65 66 74 0 "Nothing left
5310: 20 69 6e 20 74 68 65 20 71 75 65 75 65 21 22 29 in the queue!")
5320: 0a 09 20 20 20 20 3b 3b 20 49 66 20 67 65 74 20 .. ;; If get
5330: 68 65 72 65 20 74 77 69 63 65 20 74 68 65 6e 20 here twice then
5340: 77 65 20 6b 6e 6f 77 20 77 65 27 76 65 20 74 72 we know we've tr
5350: 69 65 64 20 74 6f 20 65 78 70 61 6e 64 20 61 6c ied to expand al
5360: 6c 20 69 74 65 6d 73 0a 09 20 20 20 20 3b 3b 20 l items.. ;;
5370: 73 69 6e 63 65 20 74 68 65 72 65 20 6d 75 73 74 since there must
5380: 20 62 65 20 61 20 6c 6f 67 69 63 20 69 73 73 75 be a logic issu
5390: 65 20 77 69 74 68 20 74 68 65 20 68 61 6e 64 6c e with the handl
53a0: 69 6e 67 20 6f 66 20 6c 6f 6f 70 73 20 69 6e 20 ing of loops in
53b0: 74 68 65 20 0a 09 20 20 20 20 3b 3b 20 69 74 65 the .. ;; ite
53c0: 6d 73 20 65 78 70 61 6e 64 20 70 68 61 73 65 20 ms expand phase
53d0: 77 65 20 77 69 6c 6c 20 62 72 75 74 65 20 66 6f we will brute fo
53e0: 72 63 65 20 61 6e 20 65 78 69 74 20 68 65 72 65 rce an exit here
53f0: 2e 0a 09 20 20 20 20 28 69 66 20 28 3e 20 72 75 ... (if (> ru
5400: 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d ns:nothing-left-
5410: 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 32 in-queue-count 2
5420: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
5430: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
5440: 41 52 4e 49 4e 47 3a 20 74 68 69 73 20 63 6f 6e ARNING: this con
5450: 64 69 74 69 6f 6e 20 69 73 20 74 72 69 67 67 65 dition is trigge
5460: 72 65 64 20 77 68 65 6e 20 74 68 65 72 65 20 77 red when there w
5470: 65 72 65 20 6e 6f 20 69 74 65 6d 73 20 74 6f 20 ere no items to
5480: 65 78 70 61 6e 64 20 61 6e 64 20 6e 6f 74 68 69 expand and nothi
5490: 6e 67 20 74 6f 20 72 75 6e 2e 20 50 6c 65 61 73 ng to run. Pleas
54a0: 65 20 63 68 65 63 6b 20 79 6f 75 72 20 72 75 6e e check your run
54b0: 20 66 6f 72 20 63 6f 6d 70 6c 65 74 65 6e 65 73 for completenes
54c0: 73 22 29 0a 09 09 20 20 28 65 78 69 74 20 30 29 s")... (exit 0)
54d0: 29 0a 09 09 28 73 65 74 21 20 72 75 6e 73 3a 6e )...(set! runs:n
54e0: 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 othing-left-in-q
54f0: 75 65 75 65 2d 63 6f 75 6e 74 20 28 2b 20 72 75 ueue-count (+ ru
5500: 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d ns:nothing-left-
5510: 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 31 in-queue-count 1
5520: 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 0a 0a ))).. #f)))..
5530: 20 20 20 20 20 3b 3b 20 0a 20 20 20 20 20 28 28 ;; . ((
5540: 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 or (null? prereq
5550: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 20 20 28 61 s-not-met).. (a
5560: 6e 64 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c nd (member 'topl
5570: 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 0a 09 evel testmode)..
5580: 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 6e 6f (null? no
5590: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a 20 n-completed))).
55a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
55b0: 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 65 t-info 4 "runs:e
55c0: 78 70 61 6e 64 2d 69 74 65 6d 73 3a 20 28 6f 72 xpand-items: (or
55d0: 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d (null? prereqs-
55e0: 6e 6f 74 2d 6d 65 74 29 20 28 61 6e 64 20 28 6d not-met) (and (m
55f0: 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 ember 'toplevel
5600: 74 65 73 74 6d 6f 64 65 29 28 6e 75 6c 6c 3f 20 testmode)(null?
5610: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 non-completed)))
5620: 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 "). (let ((
5630: 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 74 73 test-name (tests
5640: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
5650: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
5660: 6f 72 64 29 29 29 0a 09 28 73 65 74 65 6e 76 20 ord)))..(setenv
5670: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 "MT_TEST_NAME" t
5680: 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 28 est-name) ;; ..(
5690: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
56a0: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 ME" runname)..
56b0: 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 (runs:set-megate
56c0: 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d st-env-vars run-
56d0: 69 64 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 id inrunname: ru
56e0: 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 nname) ;; these
56f0: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
5700: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
5710: 72 6f 63 65 73 73 0a 09 28 6c 65 74 20 28 28 69 rocess..(let ((i
5720: 74 65 6d 73 2d 6c 69 73 74 20 28 69 74 65 6d 73 tems-list (items
5730: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
5740: 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 29 config tconfig))
5750: 29 0a 09 20 20 28 69 66 20 28 6c 69 73 74 3f 20 ).. (if (list?
5760: 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 20 20 20 items-list)..
5770: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 69 66 20 (begin...(if
5780: 28 6e 75 6c 6c 3f 20 69 74 65 6d 73 2d 6c 69 73 (null? items-lis
5790: 74 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 t)... (let ((
57a0: 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 test-id (rmt:get
57b0: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
57c0: 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 29 29 0a test-name ""))).
57d0: 09 09 20 20 20 20 20 20 28 6d 74 3a 74 65 73 74 .. (mt:test
57e0: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
57f0: 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 s-by-id run-id t
5800: 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 est-id "NOT_STAR
5810: 54 45 44 22 20 22 5a 45 52 4f 5f 49 54 45 4d 53 TED" "ZERO_ITEMS
5820: 22 20 22 46 61 69 6c 65 64 20 74 6f 20 72 75 6e " "Failed to run
5830: 20 64 75 65 20 74 6f 20 66 61 69 6c 65 64 20 70 due to failed p
5840: 72 65 72 65 71 75 69 73 69 74 65 73 22 29 29 29 rerequisites")))
5850: 0a 09 09 28 74 65 73 74 73 3a 74 65 73 74 71 75 ...(tests:testqu
5860: 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 74 eue-set-items! t
5870: 65 73 74 2d 72 65 63 6f 72 64 20 69 74 65 6d 73 est-record items
5880: 2d 6c 69 73 74 29 0a 09 09 28 6c 69 73 74 20 68 -list)...(list h
5890: 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e ed tal reg rerun
58a0: 73 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 s)).. (begi
58b0: 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 n...(debug:print
58c0: 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 20 70 0 "ERROR: The p
58d0: 72 6f 63 20 66 72 6f 6d 20 72 65 61 64 69 6e 67 roc from reading
58e0: 20 74 68 65 20 69 74 65 6d 73 20 74 61 62 6c 65 the items table
58f0: 20 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 did not yield a
5900: 20 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 list - please r
5910: 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 09 28 eport this")...(
5920: 65 78 69 74 20 31 29 29 29 29 29 29 0a 0a 20 20 exit 1))))))..
5930: 20 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 ((and (null?
5940: 66 61 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c fails).. (null
5950: 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 0a ? prereq-fails).
5960: 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 . (not (null?
5970: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 non-completed)))
5980: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 . (let* ((a
5990: 6c 6c 69 6e 71 75 65 75 65 20 28 6d 61 70 20 28 llinqueue (map (
59a0: 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 lambda (x)(if (s
59b0: 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a tring? x) x (db:
59c0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
59d0: 65 20 78 29 29 29 0a 20 20 20 20 20 20 20 20 09 e x))). .
59e0: 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 6e . (append n
59f0: 65 77 74 61 6c 20 72 65 72 75 6e 73 29 29 29 0a ewtal reruns))).
5a00: 09 20 20 20 20 20 3b 3b 20 70 72 65 72 65 71 73 . ;; prereqs
5a10: 74 72 73 20 69 73 20 61 20 6c 69 73 74 20 6f 66 trs is a list of
5a20: 20 74 65 73 74 20 6e 61 6d 65 73 20 61 73 20 73 test names as s
5a30: 74 72 69 6e 67 73 20 74 68 61 74 20 61 72 65 20 trings that are
5a40: 70 72 65 72 65 71 73 20 66 6f 72 20 68 65 64 0a prereqs for hed.
5a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
5a60: 65 72 65 71 73 74 72 73 20 28 64 65 6c 65 74 65 ereqstrs (delete
5a70: 2d 64 75 70 6c 69 63 61 74 65 73 20 28 6d 61 70 -duplicates (map
5a80: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 (lambda (x)(if
5a90: 28 73 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 (string? x) x (d
5aa0: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
5ab0: 61 6d 65 20 78 29 29 29 0a 09 09 09 09 09 09 20 ame x))).......
5ac0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
5ad0: 29 29 0a 09 20 20 20 20 20 3b 3b 20 61 20 70 72 )).. ;; a pr
5ae0: 65 72 65 71 20 74 68 61 74 20 69 73 20 6e 6f 74 ereq that is not
5af0: 20 66 6f 75 6e 64 20 69 6e 20 61 6c 6c 69 6e 71 found in allinq
5b00: 75 65 75 65 20 77 69 6c 6c 20 62 65 20 70 75 74 ueue will be put
5b10: 20 69 6e 20 74 68 65 20 6e 6f 74 69 6e 71 75 65 in the notinque
5b20: 75 65 20 6c 69 73 74 0a 09 20 20 20 20 20 3b 3b ue list.. ;;
5b30: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 3b . ;
5b40: 3b 20 28 6e 6f 74 69 6e 71 75 65 75 65 20 28 66 ; (notinqueue (f
5b50: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
5b60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ). ;
5b70: 3b 20 20 20 20 09 09 20 20 20 28 6e 6f 74 20 28 ; .. (not (
5b80: 6d 65 6d 62 65 72 20 78 20 61 6c 6c 69 6e 71 75 member x allinqu
5b90: 65 75 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 eue))).
5ba0: 20 20 20 20 3b 3b 20 20 20 20 09 09 20 70 72 65 ;; .. pre
5bb0: 72 65 71 73 74 72 73 29 29 0a 09 20 20 20 20 20 reqstrs))..
5bc0: 28 67 69 76 65 2d 75 70 20 20 20 20 23 66 29 29 (give-up #f))
5bd0: 0a 0a 09 3b 3b 20 57 65 20 63 61 6e 20 67 65 74 ...;; We can get
5be0: 20 68 65 72 65 20 77 68 65 6e 20 61 20 70 72 65 here when a pre
5bf0: 72 65 71 20 68 61 73 20 6e 6f 74 20 62 65 65 6e req has not been
5c00: 20 72 75 6e 20 64 75 65 20 74 6f 20 2a 69 74 2a run due to *it*
5c10: 20 68 61 76 69 6e 67 20 61 20 70 72 65 72 65 71 having a prereq
5c20: 20 74 68 61 74 20 66 61 69 6c 65 64 2e 0a 09 3b that failed...;
5c30: 3b 20 57 65 20 6e 65 65 64 20 74 6f 20 75 73 65 ; We need to use
5c40: 20 74 68 69 73 20 74 6f 20 64 65 71 75 65 75 65 this to dequeue
5c50: 20 74 68 69 73 20 69 74 65 6d 20 61 73 20 43 41 this item as CA
5c60: 4e 4e 4f 54 52 55 4e 0a 09 3b 3b 20 0a 09 28 69 NNOTRUN..;; ..(i
5c70: 66 20 28 6d 65 6d 62 65 72 20 74 65 73 74 6d 6f f (member testmo
5c80: 64 65 20 27 28 74 6f 70 6c 65 76 65 6c 29 29 0a de '(toplevel)).
5c90: 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
5ca0: 6c 61 6d 62 64 61 20 28 70 72 65 72 65 71 29 0a lambda (prereq).
5cb0: 09 09 09 28 69 66 20 28 65 71 3f 20 28 68 61 73 ...(if (eq? (has
5cc0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
5cd0: 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 ult test-registr
5ce0: 79 20 70 72 65 72 65 71 20 27 6a 75 73 74 66 69 y prereq 'justfi
5cf0: 6e 65 29 20 27 43 41 4e 4e 4f 54 52 55 4e 29 0a ne) 'CANNOTRUN).
5d00: 09 09 09 20 20 20 20 28 73 65 74 21 20 67 69 76 ... (set! giv
5d10: 65 2d 75 70 20 23 74 29 29 29 0a 09 09 20 20 20 e-up #t)))...
5d20: 20 20 20 70 72 65 72 65 71 73 74 72 73 29 29 0a prereqstrs)).
5d30: 0a 09 28 69 66 20 28 61 6e 64 20 67 69 76 65 2d ..(if (and give-
5d40: 75 70 0a 09 09 20 28 6e 6f 74 20 28 61 6e 64 20 up... (not (and
5d50: 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 75 6c 6c (null? tal)(null
5d60: 3f 20 72 65 67 29 29 29 29 0a 09 20 20 20 20 28 ? reg)))).. (
5d70: 6c 65 74 20 28 28 74 72 69 6d 6d 65 64 2d 74 61 let ((trimmed-ta
5d80: 6c 20 28 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c l (mt:discard-bl
5d90: 6f 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d ocked-tests run-
5da0: 69 64 20 68 65 64 20 74 61 6c 20 74 65 73 74 2d id hed tal test-
5db0: 72 65 63 6f 72 64 73 29 29 0a 09 09 20 20 28 74 records))... (t
5dc0: 72 69 6d 6d 65 64 2d 72 65 67 20 28 6d 74 3a 64 rimmed-reg (mt:d
5dd0: 69 73 63 61 72 64 2d 62 6c 6f 63 6b 65 64 2d 74 iscard-blocked-t
5de0: 65 73 74 73 20 72 75 6e 2d 69 64 20 68 65 64 20 ests run-id hed
5df0: 72 65 67 20 74 65 73 74 2d 72 65 63 6f 72 64 73 reg test-records
5e00: 29 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 ))).. (debu
5e10: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 g:print 1 "WARNI
5e20: 4e 47 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 NG: test " hed "
5e30: 20 68 61 73 20 64 69 73 63 61 72 64 65 64 20 70 has discarded p
5e40: 72 65 72 65 71 75 69 73 69 74 65 73 2c 20 72 65 rerequisites, re
5e50: 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 moving it from t
5e60: 68 65 20 71 75 65 75 65 22 29 0a 0a 09 20 20 20 he queue")...
5e70: 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 (let ((test-i
5e80: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
5e90: 69 64 20 72 75 6e 2d 69 64 20 68 65 64 20 22 22 id run-id hed ""
5ea0: 29 29 29 0a 09 09 28 6d 74 3a 74 65 73 74 2d 73 )))...(mt:test-s
5eb0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
5ec0: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
5ed0: 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 t-id "NOT_STARTE
5ee0: 44 22 20 22 50 52 45 51 5f 44 49 53 43 41 52 44 D" "PREQ_DISCARD
5ef0: 45 44 22 20 22 46 61 69 6c 65 64 20 74 6f 20 72 ED" "Failed to r
5f00: 75 6e 20 64 75 65 20 74 6f 20 64 69 73 63 61 72 un due to discar
5f10: 64 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 ded prerequisite
5f20: 73 22 29 29 0a 09 20 20 20 20 20 20 0a 09 20 20 s")).. ..
5f30: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 (if (and (nu
5f40: 6c 6c 3f 20 74 72 69 6d 6d 65 64 2d 74 61 6c 29 ll? trimmed-tal)
5f50: 0a 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f ... (null?
5f60: 20 74 72 69 6d 6d 65 64 2d 72 65 67 29 29 0a 09 trimmed-reg))..
5f70: 09 20 20 23 66 0a 09 09 20 20 28 6c 69 73 74 20 . #f... (list
5f80: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
5f90: 2d 68 65 64 20 74 72 69 6d 6d 65 64 2d 74 61 6c -hed trimmed-tal
5fa0: 20 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 trimmed-reg reg
5fb0: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
5fc0: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
5fd0: 2d 74 61 6c 20 74 72 69 6d 6d 65 64 2d 74 61 6c -tal trimmed-tal
5fe0: 20 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 trimmed-reg reg
5ff0: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
6000: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
6010: 2d 72 65 67 20 74 72 69 6d 6d 65 64 2d 74 61 6c -reg trimmed-tal
6020: 20 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 trimmed-reg reg
6030: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
6040: 72 65 72 75 6e 73 29 29 29 0a 09 20 20 20 20 20 reruns)))..
6050: 20 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 (list (car newt
6060: 61 6c 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 al)(append (cdr
6070: 6e 65 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 newtal) reg) '()
6080: 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 20 20 20 reruns))))..
6090: 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 66 ((and (null? f
60a0: 61 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c 3f ails).. (null?
60b0: 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 0a 09 prereq-fails)..
60c0: 20 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f (null? non-co
60d0: 6d 70 6c 65 74 65 64 29 29 0a 20 20 20 20 20 20 mpleted)).
60e0: 28 69 66 20 20 28 72 75 6e 73 3a 63 61 6e 2d 6b (if (runs:can-k
60f0: 65 65 70 2d 72 75 6e 6e 69 6e 67 3f 20 68 65 64 eep-running? hed
6100: 20 35 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 5).. (begin..
6110: 20 20 20 28 72 75 6e 73 3a 69 6e 63 2d 63 61 6e (runs:inc-can
6120: 74 2d 72 75 6e 2d 74 65 73 74 73 20 68 65 64 29 t-run-tests hed)
6130: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
6140: 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 66 61 nt-info 1 "no fa
6150: 69 6c 73 20 69 6e 20 70 72 65 72 65 71 75 69 73 ils in prerequis
6160: 69 74 65 73 20 66 6f 72 20 22 20 68 65 64 20 22 ites for " hed "
6170: 20 62 75 74 20 61 6c 73 6f 20 6e 6f 6e 65 20 72 but also none r
6180: 75 6e 6e 69 6e 67 2c 20 6b 65 65 70 69 6e 67 20 unning, keeping
6190: 22 20 68 65 64 20 22 20 66 6f 72 20 6e 6f 77 2e " hed " for now.
61a0: 20 54 72 79 20 63 6f 75 6e 74 3a 20 22 20 28 68 Try count: " (h
61b0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
61c0: 66 61 75 6c 74 20 2a 73 65 65 6e 2d 63 61 6e 74 fault *seen-cant
61d0: 2d 72 75 6e 2d 74 65 73 74 73 2a 20 68 65 64 20 -run-tests* hed
61e0: 30 29 29 0a 09 20 20 20 20 3b 3b 20 6e 75 6d 2d 0)).. ;; num-
61f0: 72 65 74 72 69 65 73 20 63 6f 64 65 20 77 61 73 retries code was
6200: 20 68 65 72 65 0a 09 20 20 20 20 3b 3b 20 77 65 here.. ;; we
6210: 20 75 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 use this opport
6220: 75 6e 69 74 79 20 74 6f 20 6d 6f 76 65 20 63 6f unity to move co
6230: 6e 74 65 6e 74 73 20 6f 66 20 72 65 67 20 74 6f ntents of reg to
6240: 20 74 61 6c 0a 09 20 20 20 20 28 6c 69 73 74 20 tal.. (list
6250: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 (car newtal)(app
6260: 65 6e 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 end (cdr newtal)
6270: 20 72 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 reg) '() reruns
6280: 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 20 77 )) ;; an issue w
6290: 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f 74 20 ith prereqs not
62a0: 79 65 74 20 6d 65 74 3f 0a 09 20 20 28 62 65 67 yet met?.. (beg
62b0: 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 in.. (debug:p
62c0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 rint-info 1 "no
62d0: 66 61 69 6c 73 20 69 6e 20 70 72 65 72 65 71 75 fails in prerequ
62e0: 69 73 69 74 65 73 20 66 6f 72 20 22 20 68 65 64 isites for " hed
62f0: 20 22 20 62 75 74 20 6e 6f 74 68 69 6e 67 20 73 " but nothing s
6300: 65 65 6e 20 72 75 6e 6e 69 6e 67 20 69 6e 20 61 een running in a
6310: 20 77 68 69 6c 65 2c 20 64 72 6f 70 70 69 6e 67 while, dropping
6320: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 66 72 test " hed " fr
6330: 6f 6d 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 om the run queue
6340: 22 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 ").. (let ((t
6350: 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d est-id (rmt:get-
6360: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 68 test-id run-id h
6370: 65 64 20 22 22 29 29 29 0a 09 20 20 20 20 20 20 ed "")))..
6380: 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 (mt:test-set-sta
6390: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
63a0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 run-id test-id "
63b0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 54 49 NOT_STARTED" "TI
63c0: 4d 45 44 5f 4f 55 54 22 20 22 4e 6f 74 68 69 6e MED_OUT" "Nothin
63d0: 67 20 73 65 65 6e 20 72 75 6e 6e 69 6e 67 20 69 g seen running i
63e0: 6e 20 61 20 77 68 69 6c 65 2e 22 29 29 0a 09 20 n a while."))..
63f0: 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 (list (runs:q
6400: 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 ueue-next-hed ta
6410: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
6420: 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a full)... (runs:
6430: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
6440: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
6450: 67 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 gfull)... (runs
6460: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
6470: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
6480: 65 67 66 75 6c 6c 29 0a 09 09 20 20 72 65 72 75 egfull)... reru
6490: 6e 73 29 29 29 29 0a 0a 20 20 20 20 20 28 28 61 ns)))).. ((a
64a0: 6e 64 20 0a 20 20 20 20 20 20 20 28 6f 72 20 28 nd . (or (
64b0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 not (null? fails
64c0: 29 29 0a 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c )).. (not (nul
64d0: 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 l? prereq-fails)
64e0: 29 29 0a 20 20 20 20 20 20 20 28 6d 65 6d 62 65 )). (membe
64f0: 72 20 27 6e 6f 72 6d 61 6c 20 74 65 73 74 6d 6f r 'normal testmo
6500: 64 65 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 de)). (debu
6510: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
6520: 74 65 73 74 20 22 20 20 68 65 64 20 22 20 28 6d test " hed " (m
6530: 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 ode=" testmode "
6540: 29 20 68 61 73 20 66 61 69 6c 65 64 20 70 72 65 ) has failed pre
6550: 72 65 71 75 69 73 69 74 65 28 73 29 3b 20 22 0a requisite(s); ".
6560: 09 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ...(string-inter
6570: 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d sperse (map (lam
6580: 62 64 61 20 28 74 29 28 63 6f 6e 63 20 28 64 62 bda (t)(conc (db
6590: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
65a0: 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 me t) ":" (db:te
65b0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 22 st-get-state t)"
65c0: 2f 22 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 /"(db:test-get-s
65d0: 74 61 74 75 73 20 74 29 29 29 20 66 61 69 6c 73 tatus t))) fails
65e0: 29 20 22 2c 20 22 29 0a 09 09 09 22 2c 20 72 65 ) ", ")....", re
65f0: 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 moving it from t
6600: 6f 2d 64 6f 20 6c 69 73 74 22 29 0a 20 20 20 20 o-do list").
6610: 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 (let ((test-id
6620: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
6630: 64 20 72 75 6e 2d 69 64 20 68 65 64 20 22 22 29 d run-id hed "")
6640: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 ))..(if (not (nu
6650: 6c 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 ll? prereq-fails
6660: 29 29 0a 09 20 20 20 20 28 6d 74 3a 74 65 73 74 )).. (mt:test
6670: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
6680: 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 s-by-id run-id t
6690: 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 est-id "NOT_STAR
66a0: 54 45 44 22 20 22 50 52 45 51 5f 44 49 53 43 41 TED" "PREQ_DISCA
66b0: 52 44 45 44 22 20 22 46 61 69 6c 65 64 20 74 6f RDED" "Failed to
66c0: 20 72 75 6e 20 64 75 65 20 74 6f 20 70 72 69 6f run due to prio
66d0: 72 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 r failed prerequ
66e0: 69 73 69 74 65 73 22 29 0a 09 20 20 20 20 28 6d isites").. (m
66f0: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
6700: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
6710: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f n-id test-id "NO
6720: 54 5f 53 54 41 52 54 45 44 22 20 22 50 52 45 51 T_STARTED" "PREQ
6730: 5f 46 41 49 4c 22 20 20 20 20 20 20 22 46 61 69 _FAIL" "Fai
6740: 6c 65 64 20 74 6f 20 72 75 6e 20 64 75 65 20 74 led to run due t
6750: 6f 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 o failed prerequ
6760: 69 73 69 74 65 73 22 29 29 29 0a 20 20 20 20 20 isites"))).
6770: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e (if (or (not (n
6780: 75 6c 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 ull? reg))(not (
6790: 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 null? tal)))..
67a0: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 68 61 73 (begin.. (has
67b0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
67c0: 74 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 27 t-registry hed '
67d0: 43 41 4e 4e 4f 54 52 55 4e 29 0a 09 20 20 20 20 CANNOTRUN)..
67e0: 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 (list (runs:queu
67f0: 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 e-next-hed tal r
6800: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6810: 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 l)... (runs:que
6820: 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 ue-next-tal tal
6830: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
6840: 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 ll)... (runs:qu
6850: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
6860: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
6870: 75 6c 6c 29 0a 09 09 20 20 28 63 6f 6e 73 20 68 ull)... (cons h
6880: 65 64 20 72 65 72 75 6e 73 29 29 29 0a 09 20 20 ed reruns)))..
6890: 23 66 29 29 20 3b 3b 20 23 66 20 66 6c 61 67 73 #f)) ;; #f flags
68a0: 20 64 6f 20 6e 6f 74 20 6c 6f 6f 70 0a 0a 20 20 do not loop..
68b0: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e ((and (not (n
68c0: 75 6c 6c 3f 20 66 61 69 6c 73 29 29 28 6d 65 6d ull? fails))(mem
68d0: 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 ber 'toplevel te
68e0: 73 74 6d 6f 64 65 29 29 0a 20 20 20 20 20 20 28 stmode)). (
68f0: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
6900: 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 l? reg))(not (nu
6910: 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 28 ll? tal))).. (
6920: 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 6c list (car newtal
6930: 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e 65 )(append (cdr ne
6940: 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 72 wtal) reg) '() r
6950: 65 72 75 6e 73 29 0a 09 20 20 23 66 29 29 20 0a eruns).. #f)) .
6960: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 75 6e ((null? run
6970: 6e 61 62 6c 65 73 29 20 23 66 29 20 3b 3b 20 69 nables) #f) ;; i
6980: 66 20 77 65 20 67 65 74 20 68 65 72 65 20 61 6e f we get here an
6990: 64 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 d non-completed
69a0: 69 73 20 6e 75 6c 6c 20 74 68 65 20 69 74 27 73 is null the it's
69b0: 20 61 6c 6c 20 6f 76 65 72 2e 0a 20 20 20 20 20 all over..
69c0: 28 65 6c 73 65 0a 20 20 20 20 20 20 28 64 65 62 (else. (deb
69d0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
69e0: 49 4e 47 3a 20 46 41 49 4c 53 20 6f 72 20 69 6e ING: FAILS or in
69f0: 63 6f 6d 70 6c 65 74 65 20 74 65 73 74 73 20 6d complete tests m
6a00: 61 79 62 65 20 70 72 65 76 65 6e 74 69 6e 67 20 aybe preventing
6a10: 63 6f 6d 70 6c 65 74 69 6f 6e 20 6f 66 20 74 68 completion of th
6a20: 69 73 20 72 75 6e 2e 20 57 61 74 63 68 20 66 6f is run. Watch fo
6a30: 72 20 69 73 73 75 65 73 20 77 69 74 68 20 74 65 r issues with te
6a40: 73 74 20 22 20 68 65 64 20 22 2c 20 63 6f 6e 74 st " hed ", cont
6a50: 69 6e 75 69 6e 67 20 66 6f 72 20 6e 6f 77 22 29 inuing for now")
6a60: 0a 20 20 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 . ;; (list
6a70: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
6a80: 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 -hed tal reg reg
6a90: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 20 len regfull).
6aa0: 20 20 20 3b 3b 20 20 20 09 28 72 75 6e 73 3a 71 ;; .(runs:q
6ab0: 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 ueue-next-tal ta
6ac0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
6ad0: 66 75 6c 6c 29 0a 20 20 20 20 20 20 3b 3b 20 20 full). ;;
6ae0: 20 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 .(runs:queue-ne
6af0: 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 xt-reg tal reg r
6b00: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 eglen regfull).
6b10: 20 20 20 20 20 3b 3b 20 20 20 09 72 65 72 75 6e ;; .rerun
6b20: 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 28 s). (list (
6b30: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
6b40: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
6b50: 6e 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ns)))))..(define
6b60: 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 (runs:mixed-lis
6b70: 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 t-testname-and-t
6b80: 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d estrec->list-of-
6b90: 73 74 72 69 6e 67 73 20 69 6e 6c 73 74 29 0a 20 strings inlst).
6ba0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 69 6e 6c 73 (if (null? inls
6bb0: 74 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 t). '().
6bc0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
6bd0: 28 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 64 0a (t).. (cond.
6be0: 09 20 20 20 20 20 20 28 28 76 65 63 74 6f 72 3f . ((vector?
6bf0: 20 74 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 t).. (let
6c00: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 ((test-name (db
6c10: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
6c20: 6d 65 20 74 29 29 0a 09 09 20 20 20 20 20 28 69 me t))... (i
6c30: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
6c40: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
6c50: 74 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 t))... (test
6c60: 2d 73 74 61 74 65 20 28 64 62 3a 74 65 73 74 2d -state (db:test-
6c70: 67 65 74 2d 73 74 61 74 65 20 74 29 29 0a 09 09 get-state t))...
6c80: 20 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 (test-statu
6c90: 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 s (db:test-get-s
6ca0: 74 61 74 75 73 20 74 29 29 29 0a 09 09 20 28 63 tatus t)))... (c
6cb0: 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 onc test-name (i
6cc0: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 f (equal? item-p
6cd0: 61 74 68 20 22 22 29 20 22 22 20 22 2f 22 29 20 ath "") "" "/")
6ce0: 69 74 65 6d 2d 70 61 74 68 20 22 3a 22 20 74 65 item-path ":" te
6cf0: 73 74 2d 73 74 61 74 65 20 22 2f 22 20 74 65 73 st-state "/" tes
6d00: 74 2d 73 74 61 74 75 73 29 29 29 0a 09 20 20 20 t-status)))..
6d10: 20 20 20 28 28 73 74 72 69 6e 67 3f 20 74 29 0a ((string? t).
6d20: 09 20 20 20 20 20 20 20 74 29 0a 09 20 20 20 20 . t)..
6d30: 20 20 28 65 6c 73 65 20 0a 09 20 20 20 20 20 20 (else ..
6d40: 20 28 63 6f 6e 63 20 74 29 29 29 29 0a 09 20 20 (conc t))))..
6d50: 20 69 6e 6c 73 74 29 29 29 0a 0a 28 64 65 66 69 inlst)))..(defi
6d60: 6e 65 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 73 ne (runs:process
6d70: 2d 65 78 70 61 6e 64 65 64 2d 74 65 73 74 73 20 -expanded-tests
6d80: 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 hed tal reg reru
6d90: 6e 73 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c ns reglen regful
6da0: 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 20 72 75 l test-record ru
6db0: 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 nname test-name
6dc0: 69 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 6f item-path jobgro
6dd0: 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e up max-concurren
6de0: 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 t-jobs run-id wa
6df0: 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 itons item-path
6e00: 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 61 testmode test-pa
6e10: 74 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 tts required-tes
6e20: 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ts test-registry
6e30: 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 20 registry-mutex
6e40: 66 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 72 75 flags keyvals ru
6e50: 6e 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 6c n-info newtal al
6e60: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
6e70: 20 69 74 65 6d 6d 61 70 29 0a 20 20 28 6c 65 74 itemmap). (let
6e80: 2a 20 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 * ((run-limits-i
6e90: 6e 66 6f 20 20 20 20 20 20 20 20 20 28 72 75 6e nfo (run
6ea0: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
6eb0: 65 73 74 73 20 72 75 6e 2d 69 64 20 6a 6f 62 67 ests run-id jobg
6ec0: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
6ed0: 65 6e 74 2d 6a 6f 62 73 29 29 20 3b 3b 20 6c 6f ent-jobs)) ;; lo
6ee0: 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 6a ok at the test j
6ef0: 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 obgroup and tot
6f00: 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 20 28 jobs running.. (
6f10: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 20 have-resources
6f20: 20 20 20 20 20 20 20 20 28 63 61 72 20 72 75 6e (car run
6f30: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 29 0a 09 -limits-info))..
6f40: 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 (num-running
6f50: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d (list-
6f60: 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 ref run-limits-i
6f70: 6e 66 6f 20 31 29 29 0a 09 20 28 6e 75 6d 2d 72 nfo 1)).. (num-r
6f80: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
6f90: 75 70 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e up (list-ref run
6fa0: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 29 29 -limits-info 2))
6fb0: 20 0a 09 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 .. (max-concurr
6fc0: 65 6e 74 2d 6a 6f 62 73 20 20 20 20 20 28 6c 69 ent-jobs (li
6fd0: 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 st-ref run-limit
6fe0: 73 2d 69 6e 66 6f 20 33 29 29 0a 09 20 28 6a 6f s-info 3)).. (jo
6ff0: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 b-group-limit
7000: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
7010: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 run-limits-info
7020: 34 29 29 0a 09 20 28 70 72 65 72 65 71 73 2d 6e 4)).. (prereqs-n
7030: 6f 74 2d 6d 65 74 20 20 20 20 20 20 20 20 20 28 ot-met (
7040: 72 6d 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d rmt:get-prereqs-
7050: 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 not-met run-id w
7060: 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 aitons item-path
7070: 20 74 65 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 testmode itemma
7080: 70 3a 20 69 74 65 6d 6d 61 70 29 29 0a 09 20 3b p: itemmap)).. ;
7090: 3b 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ; (prereqs-not-m
70a0: 65 74 20 20 20 20 20 20 20 20 20 28 6d 74 3a 6c et (mt:l
70b0: 61 7a 79 2d 67 65 74 2d 70 72 65 72 65 71 73 2d azy-get-prereqs-
70c0: 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 not-met run-id w
70d0: 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 aitons item-path
70e0: 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 20 mode: testmode
70f0: 69 74 65 6d 6d 61 70 3a 20 69 74 65 6d 6d 61 70 itemmap: itemmap
7100: 29 29 0a 09 20 28 66 61 69 6c 73 20 20 20 20 20 )).. (fails
7110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
7120: 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 uns:calc-fails p
7130: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
7140: 0a 09 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 .. (non-complete
7150: 64 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e d (run
7160: 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c s:calc-not-compl
7170: 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 eted prereqs-not
7180: 2d 6d 65 74 29 29 0a 09 20 28 6c 6f 6f 70 2d 6c -met)).. (loop-l
7190: 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ist
71a0: 20 20 28 6c 69 73 74 20 68 65 64 20 74 61 6c 20 (list hed tal
71b0: 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 3b reg reruns)).. ;
71c0: 3b 20 63 6f 6e 66 69 67 75 72 65 20 74 68 65 20 ; configure the
71d0: 6c 6f 61 64 20 72 75 6e 6e 65 72 0a 09 20 28 6e load runner.. (n
71e0: 75 6d 63 70 75 73 20 20 20 20 20 20 20 20 20 20 umcpus
71f0: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 (common:g
7200: 65 74 2d 6e 75 6d 2d 63 70 75 73 29 29 0a 09 20 et-num-cpus))..
7210: 28 6d 61 78 6c 6f 61 64 20 20 20 20 20 20 20 20 (maxload
7220: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
7230: 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f ->number (or (co
7240: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
7250: 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f nfigdat* "jobtoo
7260: 6c 73 22 20 22 6d 61 78 6c 6f 61 64 22 29 20 22 ls" "maxload") "
7270: 33 22 29 29 29 0a 09 20 28 77 61 69 74 64 65 6c 3"))).. (waitdel
7280: 61 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ay
7290: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
72a0: 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (or (configf:lo
72b0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
72c0: 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 77 61 69 "jobtools" "wai
72d0: 74 64 65 6c 61 79 22 29 20 22 36 30 22 29 29 29 tdelay") "60")))
72e0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
72f0: 6e 74 2d 69 6e 66 6f 20 34 20 22 68 61 76 65 2d nt-info 4 "have-
7300: 72 65 73 6f 75 72 63 65 73 3a 20 22 20 68 61 76 resources: " hav
7310: 65 2d 72 65 73 6f 75 72 63 65 73 20 22 20 70 72 e-resources " pr
7320: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 28 ereqs-not-met: (
7330: 22 20 0a 09 09 20 20 20 20 20 20 28 73 74 72 69 " ... (stri
7340: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
7350: 09 09 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c .. (map (l
7360: 61 6d 62 64 61 20 28 74 29 0a 09 09 09 20 20 20 ambda (t)....
7370: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
7380: 74 29 0a 09 09 09 09 20 20 28 63 6f 6e 63 20 28 t)..... (conc (
7390: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
73a0: 65 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 e t) "/" (db:tes
73b0: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 t-get-status t))
73c0: 0a 09 09 09 09 20 20 28 63 6f 6e 63 20 22 20 57 ..... (conc " W
73d0: 41 52 4e 49 4e 47 3a 20 74 20 69 73 20 6e 6f 74 ARNING: t is not
73e0: 20 61 20 76 65 63 74 6f 72 3d 22 20 74 20 29 29 a vector=" t ))
73f0: 29 0a 09 09 09 20 20 20 20 70 72 65 72 65 71 73 ).... prereqs
7400: 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 20 -not-met) ", ")
7410: 22 29 20 66 61 69 6c 73 3a 20 22 20 66 61 69 6c ") fails: " fail
7420: 73 29 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 s). . (if
7430: 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
7440: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
7450: 29 29 0a 09 20 20 20 20 20 28 72 75 6e 73 3a 6c )).. (runs:l
7460: 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 77 ownoise (conc "w
7470: 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 20 aiting on tests
7480: 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 " prereqs-not-me
7490: 74 20 68 65 64 29 20 36 30 29 29 0a 09 28 64 65 t hed) 60))..(de
74a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
74b0: 20 22 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 "waiting on tes
74c0: 74 73 3b 20 22 20 28 73 74 72 69 6e 67 2d 69 6e ts; " (string-in
74d0: 74 65 72 73 70 65 72 73 65 20 28 72 75 6e 73 3a tersperse (runs:
74e0: 6d 69 78 65 64 2d 6c 69 73 74 2d 74 65 73 74 6e mixed-list-testn
74f0: 61 6d 65 2d 61 6e 64 2d 74 65 73 74 72 65 63 2d ame-and-testrec-
7500: 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 69 6e 67 73 >list-of-strings
7510: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
7520: 29 20 22 2c 20 22 29 29 29 0a 0a 20 20 20 20 3b ) ", "))).. ;
7530: 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 ; Don't know at
7540: 74 68 69 73 20 74 69 6d 65 20 69 66 20 74 68 65 this time if the
7550: 20 74 65 73 74 20 68 61 76 65 20 62 65 65 6e 20 test have been
7560: 6c 61 75 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 launched at some
7570: 20 74 69 6d 65 20 69 6e 20 74 68 65 20 70 61 73 time in the pas
7580: 74 0a 20 20 20 20 3b 3b 20 69 2e 65 2e 20 69 73 t. ;; i.e. is
7590: 20 74 68 69 73 20 61 20 72 65 2d 6c 61 75 6e 63 this a re-launc
75a0: 68 3f 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 h?. (debug:pr
75b0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 2d int-info 4 "run-
75c0: 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 3d 20 22 20 limits-info = "
75d0: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 run-limits-info)
75e0: 0a 20 20 20 20 0a 20 20 20 20 28 63 6f 6e 64 0a . . (cond.
75f0: 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 43 68 . ;; Ch
7600: 65 63 6b 20 69 74 65 6d 20 70 61 74 68 20 61 67 eck item path ag
7610: 61 69 6e 73 74 20 69 74 65 6d 2d 70 61 74 74 73 ainst item-patts
7620: 2c 20 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 , . ;;.
7630: 28 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 ((not (tests:mat
7640: 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 28 74 ch test-patts (t
7650: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
7660: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
7670: 2d 72 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 -record) item-pa
7680: 74 68 20 72 65 71 75 69 72 65 64 3a 20 72 65 71 th required: req
7690: 75 69 72 65 64 2d 74 65 73 74 73 29 29 20 3b 3b uired-tests)) ;;
76a0: 20 54 68 69 73 20 74 65 73 74 2f 69 74 65 6d 70 This test/itemp
76b0: 61 74 68 20 69 73 20 6e 6f 74 20 74 6f 20 62 65 ath is not to be
76c0: 20 72 75 6e 0a 20 20 20 20 20 20 3b 3b 20 65 6c run. ;; el
76d0: 73 65 20 74 68 65 20 72 75 6e 20 69 73 20 73 74 se the run is st
76e0: 75 63 6b 2c 20 74 65 6d 70 6f 72 61 72 69 6c 79 uck, temporarily
76f0: 20 6f 72 20 70 65 72 6d 61 6e 65 6e 74 6c 79 0a or permanently.
7700: 20 20 20 20 20 20 3b 3b 20 62 75 74 20 73 68 6f ;; but sho
7710: 75 6c 64 20 63 68 65 63 6b 20 69 66 20 69 74 20 uld check if it
7720: 69 73 20 64 75 65 20 74 6f 20 6c 61 63 6b 20 6f is due to lack o
7730: 66 20 72 65 73 6f 75 72 63 65 73 20 76 73 2e 20 f resources vs.
7740: 70 72 65 72 65 71 75 69 73 69 74 65 73 0a 20 20 prerequisites.
7750: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7760: 2d 69 6e 66 6f 20 31 20 22 53 6b 69 70 70 69 6e -info 1 "Skippin
7770: 67 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 g " (tests:testq
7780: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
7790: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 e test-record) "
77a0: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
77b0: 73 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 s it doesn't mat
77c0: 63 68 20 22 20 74 65 73 74 2d 70 61 74 74 73 29 ch " test-patts)
77d0: 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 . (if (or (
77e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
77f0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
7800: 29 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e )).. (list (run
7810: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 s:queue-next-hed
7820: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
7830: 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 regfull)...(runs
7840: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
7850: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
7860: 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a egfull)...(runs:
7870: 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 queue-next-reg t
7880: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
7890: 67 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 gfull)...reruns)
78a0: 0a 09 20 20 23 66 29 29 0a 20 20 20 20 20 0a 20 .. #f)). .
78b0: 20 20 20 20 3b 3b 20 52 65 67 69 73 74 65 72 20 ;; Register
78c0: 74 65 73 74 73 20 0a 20 20 20 20 20 3b 3b 0a 20 tests . ;;.
78d0: 20 20 20 20 28 28 6e 6f 74 20 28 68 61 73 68 2d ((not (hash-
78e0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
78f0: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
7900: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
7910: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
7920: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 ame item-path) #
7930: 66 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 f)). (debug
7940: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 50 :print-info 4 "P
7950: 72 65 2d 72 65 67 69 73 74 65 72 69 6e 67 20 74 re-registering t
7960: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
7970: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 "/" item-path "
7980: 74 6f 20 63 72 65 61 74 65 20 70 6c 61 63 65 68 to create placeh
7990: 6f 6c 64 65 72 22 20 29 0a 20 20 20 20 20 20 28 older" ). (
79a0: 69 66 20 28 65 71 3f 20 2a 74 72 61 6e 73 70 6f if (eq? *transpo
79b0: 72 74 2d 74 79 70 65 2a 20 27 66 73 29 20 3b 3b rt-type* 'fs) ;;
79c0: 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 70 61 72 no point in par
79d0: 61 6c 6c 65 6c 20 72 65 67 69 73 74 72 61 74 69 allel registrati
79e0: 6f 6e 20 69 66 20 75 73 65 20 66 73 0a 09 20 20 on if use fs..
79f0: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 72 6d 74 (begin.. (rmt
7a00: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 :general-call 'r
7a10: 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e egister-test run
7a20: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
7a30: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
7a40: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
7a50: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
7a60: 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 try (runs:make-f
7a70: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
7a80: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
7a90: 68 29 20 27 64 6f 6e 65 29 29 0a 09 20 20 28 6c h) 'done)).. (l
7aa0: 65 74 20 28 28 74 68 20 28 6d 61 6b 65 2d 74 68 et ((th (make-th
7ab0: 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a read (lambda ().
7ac0: 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f .... (mutex-lo
7ad0: 63 6b 21 20 72 65 67 69 73 74 72 79 2d 6d 75 74 ck! registry-mut
7ae0: 65 78 29 0a 09 09 09 09 20 20 20 28 68 61 73 68 ex)..... (hash
7af0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
7b00: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
7b10: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
7b20: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
7b30: 65 6d 2d 70 61 74 68 29 20 27 73 74 61 72 74 29 em-path) 'start)
7b40: 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 75 ..... (mutex-u
7b50: 6e 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 79 2d nlock! registry-
7b60: 6d 75 74 65 78 29 0a 09 09 09 09 20 20 20 3b 3b mutex)..... ;;
7b70: 20 49 66 20 68 61 76 65 6e 27 74 20 64 6f 6e 65 If haven't done
7b80: 20 69 74 20 62 65 66 6f 72 65 20 72 65 67 69 73 it before regis
7b90: 74 65 72 20 61 20 74 6f 70 20 6c 65 76 65 6c 20 ter a top level
7ba0: 74 65 73 74 20 69 66 20 74 68 69 73 20 69 73 20 test if this is
7bb0: 61 6e 20 69 74 65 6d 69 7a 65 64 20 74 65 73 74 an itemized test
7bc0: 0a 09 09 09 09 20 20 20 28 69 66 20 28 6e 6f 74 ..... (if (not
7bd0: 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c (eq? (hash-tabl
7be0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
7bf0: 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e st-registry (run
7c00: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
7c10: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
7c20: 22 22 29 20 23 66 29 20 27 64 6f 6e 65 29 29 0a "") #f) 'done)).
7c30: 09 09 09 09 20 20 20 20 20 20 20 28 72 6d 74 3a .... (rmt:
7c40: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 general-call 're
7c50: 67 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d gister-test run-
7c60: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
7c70: 61 6d 65 20 22 22 29 29 0a 09 09 09 09 20 20 20 ame "")).....
7c80: 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
7c90: 6c 20 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 l 'register-test
7ca0: 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 run-id run-id t
7cb0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7cc0: 74 68 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 th)..... (mute
7cd0: 78 2d 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 79 x-lock! registry
7ce0: 2d 6d 75 74 65 78 29 0a 09 09 09 09 20 20 20 28 -mutex)..... (
7cf0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
7d00: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
7d10: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
7d20: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
7d30: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 64 6f e item-path) 'do
7d40: 6e 65 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 ne)..... (mute
7d50: 78 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 73 74 x-unlock! regist
7d60: 72 79 2d 6d 75 74 65 78 29 29 0a 09 09 09 09 20 ry-mutex)).....
7d70: 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 (conc test-name
7d80: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
7d90: 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 ).. (thread-s
7da0: 74 61 72 74 21 20 74 68 29 29 29 0a 20 20 20 20 tart! th))).
7db0: 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 (runs:shrink-c
7dc0: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
7dd0: 73 2d 63 6f 75 6e 74 29 20 20 20 3b 3b 20 44 45 s-count) ;; DE
7de0: 4c 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 LAY TWEAKER (sti
7df0: 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 ll needed?).
7e00: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c (if (and (null
7e10: 3f 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 ? tal)(null? reg
7e20: 29 29 0a 09 20 20 28 6c 69 73 74 20 68 65 64 20 )).. (list hed
7e30: 74 61 6c 20 28 61 70 70 65 6e 64 20 72 65 67 20 tal (append reg
7e40: 28 6c 69 73 74 20 68 65 64 29 29 20 72 65 72 75 (list hed)) reru
7e50: 6e 73 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 ns).. (list (ru
7e60: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
7e70: 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e d tal reg reglen
7e80: 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e regfull)...(run
7e90: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
7ea0: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
7eb0: 72 65 67 66 75 6c 6c 29 0a 09 09 3b 3b 20 4e 42 regfull)...;; NB
7ec0: 2f 2f 20 48 65 72 65 20 77 65 20 61 72 65 20 62 // Here we are b
7ed0: 75 69 6c 64 69 6e 67 20 72 65 67 20 61 73 20 77 uilding reg as w
7ee0: 65 20 72 65 67 69 73 74 65 72 20 74 65 73 74 73 e register tests
7ef0: 0a 09 09 3b 3b 20 69 66 20 72 65 67 66 75 6c 6c ...;; if regfull
7f00: 20 77 65 20 6d 75 73 74 20 70 6f 70 20 74 68 65 we must pop the
7f10: 20 66 72 6f 6e 74 20 69 74 65 6d 20 6f 66 66 20 front item off
7f20: 72 65 67 0a 09 09 28 69 66 20 72 65 67 66 75 6c reg...(if regful
7f30: 6c 0a 09 09 20 20 20 20 28 61 70 70 65 6e 64 20 l... (append
7f40: 28 63 64 72 20 72 65 67 29 20 28 6c 69 73 74 20 (cdr reg) (list
7f50: 68 65 64 29 29 0a 09 09 20 20 20 20 28 61 70 70 hed))... (app
7f60: 65 6e 64 20 72 65 67 20 28 6c 69 73 74 20 68 65 end reg (list he
7f70: 64 29 29 29 0a 09 09 72 65 72 75 6e 73 29 29 29 d)))...reruns)))
7f80: 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 41 . . ;; A
7f90: 74 20 74 68 69 73 20 70 6f 69 6e 74 20 68 65 64 t this point hed
7fa0: 20 74 65 73 74 20 72 65 67 69 73 74 72 61 74 69 test registrati
7fb0: 6f 6e 20 6d 75 73 74 20 62 65 20 63 6f 6d 70 6c on must be compl
7fc0: 65 74 65 64 2e 0a 20 20 20 20 20 3b 3b 0a 20 20 eted.. ;;.
7fd0: 20 20 20 28 28 65 71 3f 20 28 68 61 73 68 2d 74 ((eq? (hash-t
7fe0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7ff0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
8000: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
8010: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
8020: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 me item-path) #f
8030: 29 0a 09 20 20 20 27 73 74 61 72 74 29 0a 20 20 ).. 'start).
8040: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8050: 2d 69 6e 66 6f 20 30 20 22 57 61 69 74 69 6e 67 -info 0 "Waiting
8060: 20 6f 6e 20 74 65 73 74 20 72 65 67 69 73 74 72 on test registr
8070: 61 74 69 6f 6e 28 73 29 3a 20 22 0a 09 09 09 28 ation(s): "....(
8080: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
8090: 73 65 20 0a 09 09 09 20 28 66 69 6c 74 65 72 20 se .... (filter
80a0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
80b0: 20 20 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 (eq? (hash-ta
80c0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
80d0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 78 20 test-registry x
80e0: 23 66 29 20 27 73 74 61 72 74 29 29 0a 09 09 09 #f) 'start))....
80f0: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 . (hash-table-ke
8100: 79 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ys test-registry
8110: 29 29 0a 09 09 09 20 22 2c 20 22 29 29 0a 20 20 )).... ", ")).
8120: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
8130: 70 21 20 30 2e 31 29 0a 20 20 20 20 20 20 28 6c p! 0.1). (l
8140: 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 ist hed tal reg
8150: 72 65 72 75 6e 73 29 29 0a 20 20 20 20 20 0a 20 reruns)). .
8160: 20 20 20 20 3b 3b 20 49 66 20 6e 6f 20 72 65 73 ;; If no res
8170: 6f 75 72 63 65 73 20 61 72 65 20 61 76 61 69 6c ources are avail
8180: 61 62 6c 65 20 6a 75 73 74 20 6b 69 6c 6c 20 74 able just kill t
8190: 69 6d 65 20 61 6e 64 20 6c 6f 6f 70 20 61 67 61 ime and loop aga
81a0: 69 6e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 in. ;;.
81b0: 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 ((not have-resou
81c0: 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 rces) ;; simply
81d0: 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 try again after
81e0: 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 waiting a second
81f0: 0a 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 . (if (runs
8200: 3a 6c 6f 77 6e 6f 69 73 65 20 22 6e 6f 20 72 65 :lownoise "no re
8210: 73 6f 75 72 63 65 73 22 20 36 30 29 0a 09 20 20 sources" 60)..
8220: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
8230: 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 o 1 "no resource
8240: 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 s to run new tes
8250: 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 ts, waiting ..."
8260: 29 29 0a 20 20 20 20 20 20 3b 3b 20 48 61 76 65 )). ;; Have
8270: 20 67 6f 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 gone back and f
8280: 6f 72 74 68 20 6f 6e 20 74 68 69 73 20 62 75 74 orth on this but
8290: 20 64 62 20 73 74 61 72 76 61 74 69 6f 6e 20 69 db starvation i
82a0: 73 20 61 6e 20 69 73 73 75 65 2e 0a 20 20 20 20 s an issue..
82b0: 20 20 3b 3b 20 77 61 69 74 20 6f 6e 65 20 73 65 ;; wait one se
82c0: 63 6f 6e 64 20 62 65 66 6f 72 65 20 6c 6f 6f 6b cond before look
82d0: 69 6e 67 20 61 67 61 69 6e 20 74 6f 20 72 75 6e ing again to run
82e0: 20 6a 6f 62 73 2e 0a 20 20 20 20 20 20 28 74 68 jobs.. (th
82f0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 read-sleep! 1).
8300: 20 20 20 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ;; could ha
8310: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
8320: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
8330: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
8340: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
8350: 0a 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 . (list (ca
8360: 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 r newtal)(cdr ne
8370: 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 wtal) reg reruns
8380: 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b )). . ;;
8390: 20 54 68 69 73 20 69 73 20 74 68 65 20 66 69 6e This is the fin
83a0: 61 6c 20 73 74 61 67 65 2c 20 65 76 65 72 79 74 al stage, everyt
83b0: 68 69 6e 67 20 69 73 20 69 6e 20 70 6c 61 63 65 hing is in place
83c0: 20 73 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 so launch the t
83d0: 65 73 74 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 est. ;;.
83e0: 20 28 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f ((and have-reso
83f0: 75 72 63 65 73 0a 09 20 20 20 28 6f 72 20 28 6e urces.. (or (n
8400: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
8410: 2d 6d 65 74 29 0a 09 20 20 20 20 20 20 20 28 61 -met).. (a
8420: 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 nd (eq? testmode
8430: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 20 20 'toplevel)...
8440: 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d (null? non-com
8450: 70 6c 65 74 65 64 29 29 29 29 0a 20 20 20 20 20 pleted)))).
8460: 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ;; (hash-table-
8470: 64 65 6c 65 74 65 21 20 2a 6d 61 78 2d 74 72 69 delete! *max-tri
8480: 65 73 2d 68 61 73 68 2a 20 28 72 75 6e 73 3a 6d es-hash* (runs:m
8490: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
84a0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
84b0: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 3b m-path)). ;
84c0: 3b 20 77 65 20 61 72 65 20 67 6f 69 6e 67 20 74 ; we are going t
84d0: 6f 20 72 65 73 65 74 20 61 6c 6c 20 74 68 65 20 o reset all the
84e0: 63 6f 75 6e 74 65 72 73 20 66 6f 72 20 74 65 73 counters for tes
84f0: 74 20 72 65 74 72 69 65 73 20 62 79 20 73 65 74 t retries by set
8500: 74 69 6e 67 20 61 20 6e 65 77 20 68 61 73 68 20 ting a new hash
8510: 74 61 62 6c 65 0a 20 20 20 20 20 20 3b 3b 20 74 table. ;; t
8520: 68 69 73 20 6d 65 61 6e 73 20 74 68 65 79 20 77 his means they w
8530: 69 6c 6c 20 69 6e 63 72 65 6d 65 6e 74 20 6f 6e ill increment on
8540: 6c 79 20 77 68 65 6e 20 6e 6f 74 68 69 6e 67 20 ly when nothing
8550: 63 61 6e 20 62 65 20 72 75 6e 0a 20 20 20 20 20 can be run.
8560: 20 28 73 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 (set! *max-trie
8570: 73 2d 68 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 s-hash* (make-ha
8580: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 20 20 sh-table)).
8590: 20 3b 3b 20 77 65 6c 6c 2c 20 66 69 72 73 74 20 ;; well, first
85a0: 6c 65 74 73 20 73 65 65 20 69 66 20 63 70 75 20 lets see if cpu
85b0: 6c 6f 61 64 20 74 68 72 6f 74 74 6c 69 6e 67 20 load throttling
85c0: 69 73 20 65 6e 61 62 6c 65 64 2e 20 49 66 20 73 is enabled. If s
85d0: 6f 20 77 61 69 74 20 61 72 6f 75 6e 64 20 75 6e o wait around un
85e0: 74 69 6c 20 74 68 65 0a 20 20 20 20 20 20 3b 3b til the. ;;
85f0: 20 61 76 65 72 61 67 65 20 63 70 75 20 6c 6f 61 average cpu loa
8600: 64 20 69 73 20 75 6e 64 65 72 20 74 68 65 20 74 d is under the t
8610: 68 72 65 73 68 6f 6c 64 20 62 65 66 6f 72 65 20 hreshold before
8620: 63 6f 6e 74 69 6e 75 69 6e 67 0a 20 20 20 20 20 continuing.
8630: 20 28 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (if (configf:lo
8640: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
8650: 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 "jobtools" "max
8660: 6c 6f 61 64 22 29 20 3b 3b 20 6f 6e 6c 79 20 67 load") ;; only g
8670: 61 74 65 20 69 66 20 6d 61 78 6c 6f 61 64 20 69 ate if maxload i
8680: 73 20 73 70 65 63 69 66 69 65 64 0a 09 20 20 28 s specified.. (
8690: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
86a0: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
86b0: 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 numcpus waitdela
86c0: 79 29 29 0a 20 20 20 20 20 20 28 72 75 6e 3a 74 y)). (run:t
86d0: 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 est run-id run-i
86e0: 6e 66 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e nfo keyvals runn
86f0: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ame test-record
8700: 66 6c 61 67 73 20 23 66 20 74 65 73 74 2d 72 65 flags #f test-re
8710: 67 69 73 74 72 79 20 61 6c 6c 2d 74 65 73 74 73 gistry all-tests
8720: 2d 72 65 67 69 73 74 72 79 29 0a 20 20 20 20 20 -registry).
8730: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
8740: 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
8750: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
8760: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
8770: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 ame item-path) '
8780: 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 20 20 28 running). (
8790: 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d runs:shrink-can-
87a0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
87b0: 6f 75 6e 74 29 20 20 3b 3b 20 44 45 4c 41 59 20 ount) ;; DELAY
87c0: 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e TWEAKER (still n
87d0: 65 65 64 65 64 3f 29 0a 20 20 20 20 20 20 3b 3b eeded?). ;;
87e0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
87f0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a *global-delta*).
8800: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
8810: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 ot (null? tal))(
8820: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 not (null? reg))
8830: 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e 73 ).. (list (runs
8840: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
8850: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
8860: 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a egfull)...(runs:
8870: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
8880: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
8890: 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 gfull)...(runs:q
88a0: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 ueue-next-reg ta
88b0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
88c0: 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 0a full)...reruns).
88d0: 09 20 20 23 66 29 29 0a 20 20 20 20 20 0a 20 20 . #f)). .
88e0: 20 20 20 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 ;; must be we
88f0: 20 68 61 76 65 20 75 6e 6d 65 74 20 70 72 65 72 have unmet prer
8900: 65 71 75 69 73 69 74 65 73 0a 20 20 20 20 20 3b equisites. ;
8910: 3b 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 ;. (else.
8920: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8930: 34 20 22 46 41 49 4c 53 3a 20 22 20 66 61 69 6c 4 "FAILS: " fail
8940: 73 29 0a 20 20 20 20 20 20 3b 3b 20 49 66 20 6f s). ;; If o
8950: 6e 65 20 6f 72 20 6d 6f 72 65 20 6f 66 20 74 68 ne or more of th
8960: 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 e prereqs-not-me
8970: 74 20 61 72 65 20 46 41 49 4c 20 74 68 65 6e 20 t are FAIL then
8980: 77 65 20 63 61 6e 20 69 73 73 75 65 0a 20 20 20 we can issue.
8990: 20 20 20 3b 3b 20 61 20 6d 65 73 73 61 67 65 20 ;; a message
89a0: 61 6e 64 20 64 72 6f 70 20 68 65 64 20 66 72 6f and drop hed fro
89b0: 6d 20 74 68 65 20 69 74 65 6d 73 20 74 6f 20 62 m the items to b
89c0: 65 20 70 72 6f 63 65 73 73 65 64 2e 0a 20 20 20 e processed..
89d0: 20 20 20 3b 3b 20 28 72 75 6e 73 3a 6d 69 78 65 ;; (runs:mixe
89e0: 64 2d 6c 69 73 74 2d 74 65 73 74 6e 61 6d 65 2d d-list-testname-
89f0: 61 6e 64 2d 74 65 73 74 72 65 63 2d 3e 6c 69 73 and-testrec->lis
8a00: 74 2d 6f 66 2d 73 74 72 69 6e 67 73 20 70 72 65 t-of-strings pre
8a10: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 reqs-not-met).
8a20: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f (if (and (no
8a30: 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 t (null? prereqs
8a40: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 20 20 20 -not-met))..
8a50: 20 20 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 (runs:lownois
8a60: 65 20 28 63 6f 6e 63 20 22 77 61 69 74 69 6e 67 e (conc "waiting
8a70: 20 6f 6e 20 74 65 73 74 73 20 22 20 70 72 65 72 on tests " prer
8a80: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 68 65 64 29 eqs-not-met hed)
8a90: 20 36 30 29 29 0a 09 20 20 28 64 65 62 75 67 3a 60)).. (debug:
8aa0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 77 61 print-info 1 "wa
8ab0: 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 3b 20 iting on tests;
8ac0: 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 " (string-inters
8ad0: 70 65 72 73 65 20 0a 09 09 09 09 09 09 20 20 20 perse .......
8ae0: 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 (runs:mixed-lis
8af0: 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 t-testname-and-t
8b00: 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d estrec->list-of-
8b10: 73 74 72 69 6e 67 73 20 0a 09 09 09 09 09 09 20 strings .......
8b20: 20 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d prereqs-not-
8b30: 6d 65 74 29 20 22 2c 20 22 29 29 29 0a 20 20 20 met) ", "))).
8b40: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 (if (null? fa
8b50: 69 6c 73 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 ils).. (begin..
8b60: 20 20 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 ;; couldn't
8b70: 72 75 6e 2c 20 74 61 6b 65 20 61 20 62 72 65 61 run, take a brea
8b80: 74 68 65 72 0a 09 20 20 20 20 28 69 66 20 20 28 ther.. (if (
8b90: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 57 runs:lownoise "W
8ba0: 61 69 74 69 6e 67 20 66 6f 72 20 6d 6f 72 65 20 aiting for more
8bb0: 77 6f 72 6b 20 74 6f 20 64 6f 2e 2e 2e 22 20 36 work to do..." 6
8bc0: 30 29 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 0)... (debug:pri
8bd0: 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 74 69 nt-info 0 "Waiti
8be0: 6e 67 20 66 6f 72 20 6d 6f 72 65 20 77 6f 72 6b ng for more work
8bf0: 20 74 6f 20 64 6f 2e 2e 2e 22 29 29 0a 09 20 20 to do..."))..
8c00: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
8c10: 20 31 29 0a 09 20 20 20 20 28 6c 69 73 74 20 28 1).. (list (
8c20: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
8c30: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
8c40: 6e 73 29 29 0a 09 20 20 3b 3b 20 74 68 65 20 77 ns)).. ;; the w
8c50: 61 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 73 6f aiton is FAIL so
8c60: 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 72 79 no point in try
8c70: 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 20 65 ing to run hed e
8c80: 76 65 72 20 61 67 61 69 6e 0a 09 20 20 28 69 66 ver again.. (if
8c90: 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (or (not (null?
8ca0: 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 6c 6c reg))(not (null
8cb0: 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 ? tal)))..
8cc0: 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 65 64 (if (vector? hed
8cd0: 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 )... (begin...
8ce0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8cf0: 31 20 22 57 41 52 4e 49 4e 47 3a 20 44 72 6f 70 1 "WARNING: Drop
8d00: 70 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 ping test " test
8d10: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
8d20: 61 74 68 0a 09 09 09 09 20 22 20 66 72 6f 6d 20 ath..... " from
8d30: 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 the launch list
8d40: 61 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 as it has prereq
8d50: 75 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 uistes that are
8d60: 46 41 49 4c 22 29 0a 09 09 20 20 20 20 28 6c 65 FAIL")... (le
8d70: 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 6d 74 t ((test-id (rmt
8d80: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e :get-test-id run
8d90: 2d 69 64 20 68 65 64 20 22 22 29 29 29 0a 09 09 -id hed "")))...
8da0: 20 20 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 (mt:test-s
8db0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
8dc0: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
8dd0: 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 t-id "NOT_STARTE
8de0: 44 22 20 22 50 52 45 51 5f 46 41 49 4c 22 20 22 D" "PREQ_FAIL" "
8df0: 46 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 64 75 Failed to run du
8e00: 65 20 74 6f 20 66 61 69 6c 65 64 20 70 72 65 72 e to failed prer
8e10: 65 71 75 69 73 69 74 65 73 22 29 29 0a 09 09 20 equisites"))...
8e20: 20 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d (runs:shrink-
8e30: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
8e40: 74 73 2d 63 6f 75 6e 74 29 20 3b 3b 20 44 45 4c ts-count) ;; DEL
8e50: 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c AY TWEAKER (stil
8e60: 6c 20 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 20 l needed?)...
8e70: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
8e80: 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 p! *global-delta
8e90: 2a 29 0a 09 09 20 20 20 20 3b 3b 20 54 68 69 73 *)... ;; This
8ea0: 20 6e 65 78 74 20 69 73 20 66 6f 72 20 74 68 65 next is for the
8eb0: 20 69 74 65 6d 73 0a 09 09 20 20 20 20 28 6d 74 items... (mt
8ec0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
8ed0: 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 status-by-testna
8ee0: 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e me run-id test-n
8ef0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 22 4e ame item-path "N
8f00: 4f 54 5f 53 54 41 52 54 45 44 22 20 22 42 4c 4f OT_STARTED" "BLO
8f10: 43 4b 45 44 22 20 23 66 29 0a 09 09 20 20 20 20 CKED" #f)...
8f20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
8f30: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
8f40: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
8f50: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
8f60: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 72 me item-path) 'r
8f70: 65 6d 6f 76 65 64 29 0a 09 09 20 20 20 20 28 6c emoved)... (l
8f80: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
8f90: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg
8fa0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
8fb0: 0a 09 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 .... (runs:queu
8fc0: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
8fd0: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
8fe0: 6c 29 0a 09 09 09 20 20 28 72 75 6e 73 3a 71 75 l).... (runs:qu
8ff0: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
9000: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
9010: 75 6c 6c 29 0a 09 09 09 20 20 72 65 72 75 6e 73 ull).... reruns
9020: 20 3b 3b 20 57 41 53 3a 20 28 63 6f 6e 73 20 68 ;; WAS: (cons h
9030: 65 64 20 72 65 72 75 6e 73 29 20 3b 3b 20 62 75 ed reruns) ;; bu
9040: 74 20 74 68 61 74 20 6d 61 6b 65 73 20 6e 6f 20 t that makes no
9050: 73 65 6e 73 65 3f 0a 09 09 09 20 20 29 29 0a 09 sense?.... ))..
9060: 09 20 20 28 6c 65 74 20 28 28 6e 74 68 2d 74 72 . (let ((nth-tr
9070: 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 y (hash-table-re
9080: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
9090: 65 67 69 73 74 72 79 20 68 65 64 20 30 29 29 29 egistry hed 0)))
90a0: 0a 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 ... (cond...
90b0: 20 20 20 20 28 28 6d 65 6d 62 65 72 20 22 52 55 ((member "RU
90c0: 4e 4e 49 4e 47 22 20 28 6d 61 70 20 64 62 3a 74 NNING" (map db:t
90d0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 70 72 est-get-state pr
90e0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
90f0: 09 09 20 20 20 20 20 20 28 69 66 20 28 72 75 6e .. (if (run
9100: 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 s:lownoise (conc
9110: 20 22 70 6f 73 73 69 62 6c 65 20 52 55 4e 4e 49 "possible RUNNI
9120: 4e 47 20 70 72 65 72 65 71 75 69 73 74 65 73 20 NG prerequistes
9130: 22 20 68 65 64 29 20 36 30 29 0a 09 09 09 20 20 " hed) 60)....
9140: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9150: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 WARNING: test "
9160: 68 65 64 20 22 20 68 61 73 20 70 6f 73 73 69 62 hed " has possib
9170: 6c 65 20 52 55 4e 4e 49 4e 47 20 70 72 65 72 65 le RUNNING prere
9180: 71 75 69 73 69 74 65 73 2c 20 64 6f 6e 27 74 20 quisites, don't
9190: 67 69 76 65 20 75 70 20 6f 6e 20 69 74 20 79 65 give up on it ye
91a0: 74 2e 22 29 29 0a 09 09 20 20 20 20 20 20 28 74 t."))... (t
91b0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 29 0a hread-sleep! 4).
91c0: 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 72 .. (list (r
91d0: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
91e0: 65 64 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 ed newtal reg re
91f0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
9200: 09 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 . (runs:queue
9210: 2d 6e 65 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c -next-tal newtal
9220: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
9230: 75 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e ull).... (run
9240: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
9250: 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c newtal reg regl
9260: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 en regfull)....
9270: 20 20 20 72 65 72 75 6e 73 29 29 0a 09 09 20 20 reruns))...
9280: 20 20 20 28 28 6f 72 20 28 6e 6f 74 20 6e 74 68 ((or (not nth
9290: 2d 74 72 79 29 0a 09 09 09 20 20 28 61 6e 64 20 -try).... (and
92a0: 28 6e 75 6d 62 65 72 3f 20 6e 74 68 2d 74 72 79 (number? nth-try
92b0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 3c 20 6e ).... (< n
92c0: 74 68 2d 74 72 79 20 31 30 29 29 29 0a 09 09 20 th-try 10)))...
92d0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
92e0: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
92f0: 74 72 79 20 68 65 64 20 28 69 66 20 28 6e 75 6d try hed (if (num
9300: 62 65 72 3f 20 6e 74 68 2d 74 72 79 29 0a 09 09 ber? nth-try)...
9310: 09 09 09 09 09 20 20 20 20 20 28 2b 20 6e 74 68 ..... (+ nth
9320: 2d 74 72 79 20 31 29 0a 09 09 09 09 09 09 09 20 -try 1)........
9330: 20 20 20 20 30 29 29 0a 09 09 20 20 20 20 20 20 0))...
9340: 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 (if (runs:lownoi
9350: 73 65 20 28 63 6f 6e 63 20 22 6e 6f 74 20 72 65 se (conc "not re
9360: 6d 6f 76 69 6e 67 20 74 65 73 74 20 22 20 68 65 moving test " he
9370: 64 29 20 36 30 29 0a 09 09 09 20 20 28 64 65 62 d) 60).... (deb
9380: 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e ug:print 1 "WARN
9390: 49 4e 47 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e ING: not removin
93a0: 67 20 74 65 73 74 20 22 20 68 65 64 20 22 20 66 g test " hed " f
93b0: 72 6f 6d 20 71 75 65 75 65 20 61 6c 74 68 6f 75 rom queue althou
93c0: 67 68 20 69 74 20 6d 61 79 20 6e 6f 74 20 62 65 gh it may not be
93d0: 20 72 75 6e 6e 61 62 6c 65 20 64 75 65 20 74 6f runnable due to
93e0: 20 46 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 FAILED prerequi
93f0: 73 69 74 65 73 22 29 29 0a 09 09 20 20 20 20 20 sites"))...
9400: 20 3b 3b 20 6d 61 79 20 6e 6f 74 20 68 61 76 65 ;; may not have
9410: 20 70 72 6f 63 65 73 73 65 64 20 63 6f 72 72 65 processed corre
9420: 63 74 6c 79 2e 20 43 6f 75 6c 64 20 62 65 20 61 ctly. Could be a
9430: 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e 20 race condition
9440: 69 6e 20 79 6f 75 72 20 74 65 73 74 20 69 6d 70 in your test imp
9450: 6c 65 6d 65 6e 74 61 74 69 6f 6e 3f 20 44 72 6f lementation? Dro
9460: 70 70 69 6e 67 20 74 65 73 74 20 22 20 68 65 64 pping test " hed
9470: 29 20 3b 3b 20 20 22 20 61 73 20 69 74 20 68 61 ) ;; " as it ha
9480: 73 20 70 72 65 72 65 71 75 69 73 74 65 73 20 74 s prerequistes t
9490: 68 61 74 20 61 72 65 20 46 41 49 4c 2e 20 28 4e hat are FAIL. (N
94a0: 4f 54 45 3a 20 68 65 64 20 69 73 20 6e 6f 74 20 OTE: hed is not
94b0: 61 20 76 65 63 74 6f 72 29 22 29 0a 09 09 20 20 a vector)")...
94c0: 20 20 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b (runs:shrink
94d0: 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 -can-run-more-te
94e0: 73 74 73 2d 63 6f 75 6e 74 29 20 3b 3b 20 44 45 sts-count) ;; DE
94f0: 4c 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 LAY TWEAKER (sti
9500: 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 ll needed?)...
9510: 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 68 65 64 ;; (list hed
9520: 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 29 tal reg reruns)
9530: 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 6c 69 73 ... ;; (lis
9540: 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 t (car newtal)(c
9550: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 dr newtal) reg r
9560: 65 72 75 6e 73 29 0a 09 09 20 20 20 20 20 20 3b eruns)... ;
9570: 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ; (hash-table-se
9580: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
9590: 20 68 65 64 20 27 72 65 6d 6f 76 65 64 29 0a 09 hed 'removed)..
95a0: 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 72 75 . (list (ru
95b0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
95c0: 64 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 d newtal reg reg
95d0: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
95e0: 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d (runs:queue-
95f0: 6e 65 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 next-tal newtal
9600: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
9610: 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 ll).... (runs
9620: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
9630: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
9640: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
9650: 20 20 72 65 72 75 6e 73 29 29 0a 09 09 20 20 20 reruns))...
9660: 20 20 28 28 73 79 6d 62 6f 6c 3f 20 6e 74 68 2d ((symbol? nth-
9670: 74 72 79 29 0a 09 09 20 20 20 20 20 20 28 69 66 try)... (if
9680: 20 28 65 71 3f 20 6e 74 68 2d 74 72 79 20 27 72 (eq? nth-try 'r
9690: 65 6d 6f 76 65 64 29 20 3b 3b 20 72 65 6d 6f 76 emoved) ;; remov
96a0: 65 64 20 69 73 20 72 65 6d 6f 76 65 64 20 2d 20 ed is removed -
96b0: 64 72 6f 70 20 69 74 20 4e 4f 57 0a 09 09 09 20 drop it NOW....
96c0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
96d0: 0a 09 09 09 20 20 20 20 20 20 23 66 20 3b 3b 20 .... #f ;;
96e0: 79 65 73 2c 20 72 65 61 6c 6c 79 0a 09 09 09 20 yes, really....
96f0: 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 20 (list (car
9700: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
9710: 67 20 72 65 72 75 6e 73 29 29 0a 09 09 09 20 20 g reruns))....
9720: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 69 (begin.... (i
9730: 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 f (runs:lownoise
9740: 20 28 63 6f 6e 63 20 22 46 41 49 4c 45 44 20 70 (conc "FAILED p
9750: 72 65 72 65 71 75 69 73 69 74 65 73 20 6f 72 20 rerequisites or
9760: 6f 74 68 65 72 20 69 73 73 75 65 22 20 68 65 64 other issue" hed
9770: 29 20 36 30 29 0a 09 09 09 09 28 64 65 62 75 67 ) 60).....(debug
9780: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
9790: 47 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 G: test " hed "
97a0: 68 61 73 20 46 41 49 4c 45 44 20 70 72 65 72 65 has FAILED prere
97b0: 71 75 69 73 69 74 65 73 20 6f 72 20 6f 74 68 65 quisites or othe
97c0: 72 20 69 73 73 75 65 2e 20 49 6e 74 65 72 6e 61 r issue. Interna
97d0: 6c 20 73 74 61 74 65 20 22 20 6e 74 68 2d 74 72 l state " nth-tr
97e0: 79 20 22 20 77 69 6c 6c 20 62 65 20 6f 76 65 72 y " will be over
97f0: 72 69 64 64 65 6e 20 61 6e 64 20 77 65 27 6c 6c ridden and we'll
9800: 20 72 65 74 72 79 2e 22 29 29 0a 09 09 09 20 20 retry."))....
9810: 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (mt:test-set-s
9820: 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 tate-status-by-t
9830: 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 estname run-id t
9840: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
9850: 74 68 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 th "NOT_STARTED"
9860: 20 22 4b 45 45 50 5f 54 52 59 49 4e 47 22 20 23 "KEEP_TRYING" #
9870: 66 29 0a 09 09 09 20 20 20 20 28 68 61 73 68 2d f).... (hash-
9880: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
9890: 72 65 67 69 73 74 72 79 20 68 65 64 20 30 29 0a registry hed 0).
98a0: 09 09 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 ... (list (ru
98b0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
98c0: 64 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 d newtal reg reg
98d0: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
98e0: 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e . (runs:queue-n
98f0: 65 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 ext-tal newtal r
9900: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
9910: 6c 29 0a 09 09 09 09 20 20 28 72 75 6e 73 3a 71 l)..... (runs:q
9920: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 ueue-next-reg ne
9930: 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 wtal reg reglen
9940: 72 65 67 66 75 6c 6c 29 0a 09 09 09 09 20 20 72 regfull)..... r
9950: 65 72 75 6e 73 29 29 29 29 0a 09 09 20 20 20 20 eruns))))...
9960: 20 28 65 6c 73 65 0a 09 09 20 20 20 20 20 20 28 (else... (
9970: 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 if (runs:lownois
9980: 65 20 28 63 6f 6e 63 20 22 46 41 49 4c 45 44 20 e (conc "FAILED
9990: 70 72 65 72 65 71 75 69 74 65 73 74 73 20 61 6e prerequitests an
99a0: 64 20 77 65 20 74 72 69 65 64 22 20 68 65 64 29 d we tried" hed)
99b0: 20 36 30 29 0a 09 09 09 20 20 28 64 65 62 75 67 60).... (debug
99c0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
99d0: 47 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 G: test " hed "
99e0: 68 61 73 20 46 41 49 4c 45 44 20 70 72 65 72 65 has FAILED prere
99f0: 71 75 69 74 65 73 74 73 20 61 6e 64 20 77 65 27 quitests and we'
9a00: 76 65 20 74 72 69 65 64 20 61 74 20 6c 65 61 73 ve tried at leas
9a10: 74 20 31 30 20 74 69 6d 65 73 20 74 6f 20 72 75 t 10 times to ru
9a20: 6e 20 69 74 2e 20 47 69 76 69 6e 67 20 75 70 20 n it. Giving up
9a30: 6e 6f 77 2e 22 29 29 0a 09 09 20 20 20 20 20 20 now."))...
9a40: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
9a50: 30 20 22 20 20 20 20 20 20 20 20 20 70 72 65 72 0 " prer
9a60: 65 71 73 3a 20 22 20 70 72 65 72 65 71 73 2d 6e eqs: " prereqs-n
9a70: 6f 74 2d 6d 65 74 29 0a 09 09 20 20 20 20 20 20 ot-met)...
9a80: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
9a90: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 test-registry h
9aa0: 65 64 20 27 72 65 6d 6f 76 65 64 29 0a 09 09 20 ed 'removed)...
9ab0: 20 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 (mt:test-se
9ac0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
9ad0: 79 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 y-testname run-i
9ae0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
9af0: 2d 70 61 74 68 20 22 4e 4f 54 5f 53 54 41 52 54 -path "NOT_START
9b00: 45 44 22 20 22 54 45 4e 5f 53 54 52 49 4b 45 53 ED" "TEN_STRIKES
9b10: 22 20 23 66 29 0a 09 09 20 20 20 20 20 20 28 6d " #f)... (m
9b20: 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 t:roll-up-pass-f
9b30: 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 ail-counts run-i
9b40: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
9b50: 2d 70 61 74 68 20 22 46 41 49 4c 22 29 20 3b 3b -path "FAIL") ;;
9b60: 20 74 72 65 61 74 20 61 73 20 46 41 49 4c 0a 09 treat as FAIL..
9b70: 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 69 66 . (list (if
9b80: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 63 61 72 (null? tal)(car
9b90: 20 6e 65 77 74 61 6c 29 28 63 61 72 20 74 61 6c newtal)(car tal
9ba0: 29 29 0a 09 09 09 20 20 20 20 74 61 6c 0a 09 09 )).... tal...
9bb0: 09 20 20 20 20 72 65 67 0a 09 09 09 20 20 20 20 . reg....
9bc0: 72 65 72 75 6e 73 29 29 29 29 29 0a 09 20 20 20 reruns)))))..
9bd0: 20 20 20 3b 3b 20 63 61 6e 27 74 20 64 72 6f 70 ;; can't drop
9be0: 20 74 68 69 73 20 2d 20 6d 61 79 62 65 20 72 75 this - maybe ru
9bf0: 6e 6e 69 6e 67 3f 20 4a 75 73 74 20 6b 65 65 70 nning? Just keep
9c00: 20 74 72 79 69 6e 67 0a 09 20 20 20 20 20 20 28 trying.. (
9c10: 6c 65 74 20 28 28 72 75 6e 61 62 6c 65 2d 74 65 let ((runable-te
9c20: 73 74 73 20 28 72 75 6e 73 3a 72 75 6e 61 62 6c sts (runs:runabl
9c30: 65 2d 74 65 73 74 73 20 70 72 65 72 65 71 73 2d e-tests prereqs-
9c40: 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 28 69 66 not-met)))...(if
9c50: 20 28 6e 75 6c 6c 3f 20 72 75 6e 61 62 6c 65 2d (null? runable-
9c60: 74 65 73 74 73 29 0a 09 09 20 20 20 20 23 66 20 tests)... #f
9c70: 20 20 3b 3b 20 49 20 74 68 69 6e 6b 20 77 65 20 ;; I think we
9c80: 61 72 65 20 74 72 75 6c 79 20 64 6f 6e 65 20 68 are truly done h
9c90: 65 72 65 0a 09 09 20 20 20 20 28 6c 69 73 74 20 ere... (list
9ca0: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
9cb0: 2d 68 65 64 20 6e 65 77 74 61 6c 20 72 65 67 20 -hed newtal reg
9cc0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
9cd0: 09 09 09 20 20 20 20 28 72 75 6e 73 3a 71 75 65 ... (runs:que
9ce0: 75 65 2d 6e 65 78 74 2d 74 61 6c 20 6e 65 77 74 ue-next-tal newt
9cf0: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
9d00: 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 gfull).... (r
9d10: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 uns:queue-next-r
9d20: 65 67 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 eg newtal reg re
9d30: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
9d40: 09 20 20 20 20 72 65 72 75 6e 73 29 29 29 29 29 . reruns)))))
9d50: 29 29 29 29 0a 0a 3b 3b 20 73 63 61 6e 20 61 20 ))))..;; scan a
9d60: 6c 69 73 74 20 6f 66 20 74 65 73 74 73 20 6c 6f list of tests lo
9d70: 6f 6b 69 6e 67 20 74 6f 20 73 65 65 20 69 66 20 oking to see if
9d80: 61 6e 79 20 61 72 65 20 70 6f 74 65 6e 74 69 61 any are potentia
9d90: 6c 6c 79 20 72 75 6e 6e 61 62 6c 65 0a 28 64 65 lly runnable.(de
9da0: 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 61 62 fine (runs:runab
9db0: 6c 65 2d 74 65 73 74 73 20 74 65 73 74 73 29 0a le-tests tests).
9dc0: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
9dd0: 61 20 28 74 29 0a 09 20 20 20 20 28 69 66 20 28 a (t).. (if (
9de0: 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 not (vector? t))
9df0: 0a 09 09 74 0a 09 09 28 6c 65 74 20 28 28 73 74 ...t...(let ((st
9e00: 61 74 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ate (db:test-ge
9e10: 74 2d 73 74 61 74 65 20 74 29 29 0a 09 09 20 20 t-state t))...
9e20: 20 20 20 20 28 73 74 61 74 75 73 20 28 64 62 3a (status (db:
9e30: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
9e40: 74 29 29 29 0a 09 09 20 20 28 63 61 73 65 20 28 t)))... (case (
9e50: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 string->symbol s
9e60: 74 61 74 65 29 0a 09 09 20 20 20 20 28 28 43 4f tate)... ((CO
9e70: 4d 50 4c 45 54 45 44 29 20 23 66 29 0a 09 09 20 MPLETED) #f)...
9e80: 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 ((NOT_STARTED
9e90: 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 6d 65 )... (if (me
9ea0: 6d 62 65 72 20 73 74 61 74 75 73 20 27 28 22 54 mber status '("T
9eb0: 45 4e 5f 53 54 52 49 4b 45 53 22 20 22 42 4c 4f EN_STRIKES" "BLO
9ec0: 43 4b 45 44 22 20 22 50 52 45 51 5f 46 41 49 4c CKED" "PREQ_FAIL
9ed0: 22 20 22 5a 45 52 4f 5f 49 54 45 4d 53 22 20 22 " "ZERO_ITEMS" "
9ee0: 50 52 45 51 5f 44 49 53 43 41 52 44 45 44 22 20 PREQ_DISCARDED"
9ef0: 22 54 49 4d 45 44 5f 4f 55 54 22 20 29 29 0a 09 "TIMED_OUT" ))..
9f00: 09 09 20 23 66 0a 09 09 09 20 74 29 29 0a 09 09 .. #f.... t))...
9f10: 20 20 20 20 28 28 44 45 4c 45 54 45 44 29 20 23 ((DELETED) #
9f20: 66 29 0a 09 09 20 20 20 20 28 65 6c 73 65 20 74 f)... (else t
9f30: 29 29 29 29 29 0a 09 20 20 74 65 73 74 73 29 29 ))))).. tests))
9f40: 0a 0a 3b 3b 20 65 76 65 72 79 20 74 69 6d 65 20 ..;; every time
9f50: 74 68 6f 75 67 68 20 74 68 65 20 6c 6f 6f 70 20 though the loop
9f60: 69 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 74 65 increment the te
9f70: 73 74 2f 69 74 65 6d 70 61 74 74 20 76 61 6c 2e st/itempatt val.
9f80: 0a 3b 3b 20 77 68 65 6e 20 74 68 65 20 6d 69 6e .;; when the min
9f90: 20 69 73 20 3e 20 6d 61 78 2d 61 6c 6c 6f 77 65 is > max-allowe
9fa0: 64 20 61 6e 64 20 6e 6f 6e 65 20 72 75 6e 6e 69 d and none runni
9fb0: 6e 67 20 74 68 65 6e 20 66 6f 72 63 65 20 65 78 ng then force ex
9fc0: 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 6d it.;;.(define *m
9fd0: 61 78 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 28 ax-tries-hash* (
9fe0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
9ff0: 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 )..;; test-recor
a000: 64 73 20 69 73 20 61 20 68 61 73 68 20 74 61 62 ds is a hash tab
a010: 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d le testname:item
a020: 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 _path => vector
a030: 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 < testname testc
a040: 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 onfig waitons pr
a050: 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 iority items-inf
a060: 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 o ... >.(define
a070: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d (runs:run-tests-
a080: 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e queue run-id run
a090: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
a0a0: 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 67 73 20 s keyvals flags
a0b0: 74 65 73 74 2d 70 61 74 74 73 20 72 65 71 75 69 test-patts requi
a0c0: 72 65 64 2d 74 65 73 74 73 20 72 65 67 6c 65 6e red-tests reglen
a0d0: 2d 69 6e 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 -in all-tests-re
a0e0: 67 69 73 74 72 79 29 0a 20 20 3b 3b 20 41 74 20 gistry). ;; At
a0f0: 74 68 69 73 20 70 6f 69 6e 74 20 74 68 65 20 6c this point the l
a100: 69 73 74 20 6f 66 20 70 61 72 65 6e 74 20 74 65 ist of parent te
a110: 73 74 73 20 69 73 20 65 78 70 61 6e 64 65 64 20 sts is expanded
a120: 0a 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c . ;; NB// Shoul
a130: 64 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 68 d expand items h
a140: 65 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 ere and then ins
a150: 65 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 6e ert into the run
a160: 20 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 67 queue.. (debug
a170: 3a 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d 72 :print 5 "test-r
a180: 65 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d 72 ecords: " test-r
a190: 65 63 6f 72 64 73 20 22 2c 20 66 6c 61 67 73 3a ecords ", flags:
a1a0: 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e " (hash-table->
a1b0: 61 6c 69 73 74 20 66 6c 61 67 73 29 29 0a 0a 20 alist flags))..
a1c0: 20 3b 3b 20 44 6f 20 6d 61 72 6b 2d 61 6e 64 2d ;; Do mark-and-
a1d0: 66 69 6e 64 20 63 6c 65 61 6e 20 75 70 20 6f 66 find clean up of
a1e0: 20 64 62 20 62 65 66 6f 72 65 20 73 74 61 72 74 db before start
a1f0: 69 6e 67 20 72 75 6e 69 6e 67 20 6f 66 20 71 75 ing runing of qu
a200: 75 65 0a 20 20 3b 3b 0a 20 20 3b 3b 20 28 63 64 ue. ;;. ;; (cd
a210: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
a220: 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e find-and-mark-in
a230: 63 6f 6d 70 6c 65 74 65 20 23 66 29 0a 0a 20 20 complete #f)..
a240: 28 6c 65 74 20 28 28 72 75 6e 2d 69 6e 66 6f 20 (let ((run-info
a250: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d (rm
a260: 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 t:get-run-info r
a270: 75 6e 2d 69 64 29 29 0a 09 28 74 65 73 74 73 2d un-id))..(tests-
a280: 69 6e 66 6f 20 20 20 20 20 20 20 20 20 20 20 20 info
a290: 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f (mt:get-tests-fo
a2a0: 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 23 66 20 r-run run-id #f
a2b0: 27 28 29 20 27 28 29 29 29 20 3b 3b 20 20 71 72 '() '())) ;; qr
a2c0: 79 76 61 6c 73 3a 20 22 69 64 2c 74 65 73 74 6e yvals: "id,testn
a2d0: 61 6d 65 2c 69 74 65 6d 5f 70 61 74 68 22 29 29 ame,item_path"))
a2e0: 0a 09 28 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e ..(sorted-test-n
a2f0: 61 6d 65 73 20 20 20 20 20 28 74 65 73 74 73 3a ames (tests:
a300: 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 sort-by-priority
a310: 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 -and-waiton test
a320: 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 74 65 73 -records))..(tes
a330: 74 2d 72 65 67 69 73 74 72 79 20 20 20 20 20 20 t-registry
a340: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
a350: 62 6c 65 29 29 0a 09 28 72 65 67 69 73 74 72 79 ble))..(registry
a360: 2d 6d 75 74 65 78 20 20 20 20 20 20 20 20 28 6d -mutex (m
a370: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 28 6e 75 ake-mutex))..(nu
a380: 6d 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 20 m-retries
a390: 20 20 20 20 30 29 0a 09 28 6d 61 78 2d 72 65 74 0)..(max-ret
a3a0: 72 69 65 73 20 20 20 20 20 20 20 20 20 20 20 28 ries (
a3b0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
a3c0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
a3d0: 22 20 22 6d 61 78 72 65 74 72 69 65 73 22 29 29 " "maxretries"))
a3e0: 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e ..(max-concurren
a3f0: 74 2d 6a 6f 62 73 20 20 20 28 6c 65 74 20 28 28 t-jobs (let ((
a400: 6d 63 6a 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b mcj (config-look
a410: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
a420: 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 5f setup" "max_
a430: 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 concurrent_jobs"
a440: 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 61 6e )))..... (if (an
a450: 64 20 6d 63 6a 20 28 73 74 72 69 6e 67 2d 3e 6e d mcj (string->n
a460: 75 6d 62 65 72 20 6d 63 6a 29 29 0a 09 09 09 09 umber mcj)).....
a470: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
a480: 6d 62 65 72 20 6d 63 6a 29 0a 09 09 09 09 20 20 mber mcj).....
a490: 20 20 20 31 29 29 29 20 3b 3b 20 6c 65 6e 67 74 1))) ;; lengt
a4a0: 68 20 6f 66 20 74 68 65 20 72 65 67 69 73 74 65 h of the registe
a4b0: 72 20 71 75 65 75 65 20 61 68 65 61 64 0a 09 28 r queue ahead..(
a4c0: 72 65 67 6c 65 6e 20 20 20 20 20 20 20 20 20 20 reglen
a4d0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 (if (numbe
a4e0: 72 3f 20 72 65 67 6c 65 6e 2d 69 6e 29 20 72 65 r? reglen-in) re
a4f0: 67 6c 65 6e 2d 69 6e 20 31 29 29 0a 09 28 6c 61 glen-in 1))..(la
a500: 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 st-time-incomple
a510: 74 65 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d te (- (current-
a520: 73 65 63 6f 6e 64 73 29 20 39 30 30 29 29 20 3b seconds) 900)) ;
a530: 3b 20 66 6f 72 63 65 20 61 74 20 6c 65 61 73 74 ; force at least
a540: 20 6f 6e 65 20 63 6c 65 61 6e 20 75 70 20 63 79 one clean up cy
a550: 63 6c 65 0a 09 28 6c 61 73 74 2d 74 69 6d 65 2d cle..(last-time-
a560: 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 63 75 some-running (cu
a570: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
a580: 0a 0a 20 20 20 20 3b 3b 20 49 6e 69 74 69 61 6c .. ;; Initial
a590: 69 7a 65 20 74 68 65 20 74 65 73 74 2d 72 65 67 ize the test-reg
a5a0: 69 73 74 65 72 79 20 68 61 73 68 20 77 69 74 68 istery hash with
a5b0: 20 74 65 73 74 73 20 74 68 61 74 20 61 6c 72 65 tests that alre
a5c0: 61 64 79 20 68 61 76 65 20 61 20 72 65 63 6f 72 ady have a recor
a5d0: 64 0a 20 20 20 20 3b 3b 20 63 6f 6e 76 65 72 74 d. ;; convert
a5e0: 20 73 74 61 74 65 20 74 6f 20 73 79 6d 62 6f 6c state to symbol
a5f0: 20 61 6e 64 20 75 73 65 20 74 68 61 74 20 61 73 and use that as
a600: 20 74 68 65 20 68 61 73 68 20 76 61 6c 75 65 0a the hash value.
a610: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
a620: 61 6d 62 64 61 20 28 74 72 65 63 29 0a 09 09 28 ambda (trec)...(
a630: 6c 65 74 20 28 28 69 64 20 28 64 62 3a 74 65 73 let ((id (db:tes
a640: 74 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 t-get-id
a650: 74 72 65 63 29 29 0a 09 09 20 20 20 20 20 20 28 trec))... (
a660: 74 6e 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d tn (db:test-get-
a670: 74 65 73 74 6e 61 6d 65 20 20 74 72 65 63 29 29 testname trec))
a680: 0a 09 09 20 20 20 20 20 20 28 69 70 20 28 64 62 ... (ip (db
a690: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
a6a0: 61 74 68 20 74 72 65 63 29 29 0a 09 09 20 20 20 ath trec))...
a6b0: 20 20 20 28 73 74 20 28 64 62 3a 74 65 73 74 2d (st (db:test-
a6c0: 67 65 74 2d 73 74 61 74 65 20 20 20 20 20 74 72 get-state tr
a6d0: 65 63 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e ec)))... (if (n
a6e0: 6f 74 20 28 65 71 75 61 6c 3f 20 73 74 20 22 44 ot (equal? st "D
a6f0: 45 4c 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 ELETED"))...
a700: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
a710: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
a720: 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c (runs:make-full
a730: 2d 74 65 73 74 2d 6e 61 6d 65 20 74 6e 20 69 70 -test-name tn ip
a740: 29 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f ) (string->symbo
a750: 6c 20 73 74 29 29 29 29 29 0a 09 20 20 20 20 20 l st)))))..
a760: 20 74 65 73 74 73 2d 69 6e 66 6f 29 0a 20 20 20 tests-info).
a770: 20 28 73 65 74 21 20 6d 61 78 2d 72 65 74 72 69 (set! max-retri
a780: 65 73 20 28 69 66 20 28 61 6e 64 20 6d 61 78 2d es (if (and max-
a790: 72 65 74 72 69 65 73 20 28 73 74 72 69 6e 67 2d retries (string-
a7a0: 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 >number max-retr
a7b0: 69 65 73 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 ies))(string->nu
a7c0: 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 mber max-retries
a7d0: 29 20 31 30 30 29 29 0a 0a 20 20 20 20 28 6c 65 ) 100)).. (le
a7e0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
a7f0: 20 20 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 (car sorted
a800: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 -test-names))..
a810: 20 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 20 (tal
a820: 20 20 20 28 63 64 72 20 73 6f 72 74 65 64 2d 74 (cdr sorted-t
a830: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 est-names))..
a840: 20 20 20 20 28 72 65 67 20 20 20 20 20 20 20 20 (reg
a850: 20 27 28 29 29 20 3b 3b 20 72 65 67 69 73 74 65 '()) ;; registe
a860: 72 65 64 2c 20 70 75 74 20 74 68 65 73 65 20 61 red, put these a
a870: 74 20 74 68 65 20 68 65 61 64 20 6f 66 20 74 61 t the head of ta
a880: 6c 20 0a 09 20 20 20 20 20 20 20 28 72 65 72 75 l .. (reru
a890: 6e 73 20 20 20 20 20 20 27 28 29 29 29 0a 0a 20 ns '()))..
a8a0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n
a8b0: 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 ull? reruns))(de
a8c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
a8d0: 20 22 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e "reruns=" rerun
a8e0: 73 29 29 0a 0a 20 20 20 20 20 20 3b 3b 20 48 65 s)).. ;; He
a8f0: 72 65 20 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f re we mark any o
a900: 6c 64 20 64 65 66 75 6e 63 74 20 74 65 73 74 73 ld defunct tests
a910: 20 61 73 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 as incomplete.
a920: 44 6f 20 74 68 69 73 20 65 76 65 72 79 20 66 69 Do this every fi
a930: 66 74 65 65 6e 20 6d 69 6e 75 74 65 73 0a 20 20 fteen minutes.
a940: 20 20 20 20 28 69 66 20 28 3e 20 28 63 75 72 72 (if (> (curr
a950: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 6c ent-seconds)(+ l
a960: 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c ast-time-incompl
a970: 65 74 65 20 39 30 30 29 29 0a 20 20 20 20 20 20 ete 900)).
a980: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
a990: 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 (set! las
a9a0: 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 74 t-time-incomplet
a9b0: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
a9c0: 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ds)).
a9d0: 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d (rmt:find-and-m
a9e0: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 2d 61 ark-incomplete-a
a9f0: 6c 6c 2d 72 75 6e 73 29 29 29 0a 0a 20 20 20 20 ll-runs)))..
aa00: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f 70 ;; (print "Top
aa10: 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 of loop, hed="
aa20: 68 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c hed ", tal=" tal
aa30: 20 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 72 " ,reruns=" rer
aa40: 75 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 2a uns). (let*
aa50: 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 ((test-record (
aa60: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
aa70: 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 est-records hed)
aa80: 29 0a 09 20 20 20 20 20 28 74 65 73 74 2d 6e 61 ).. (test-na
aa90: 6d 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 me (tests:test
aaa0: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
aab0: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 me test-record))
aac0: 0a 09 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 .. (tconfig
aad0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
aae0: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e ueue-get-testcon
aaf0: 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 fig test-record)
ab00: 29 0a 09 20 20 20 20 20 28 6a 6f 62 67 72 6f 75 ).. (jobgrou
ab10: 70 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f p (config-loo
ab20: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 74 65 73 kup tconfig "tes
ab30: 74 5f 6d 65 74 61 22 20 22 6a 6f 62 67 72 6f 75 t_meta" "jobgrou
ab40: 70 22 29 29 0a 09 20 20 20 20 20 28 74 65 73 74 p")).. (test
ab50: 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d mode (let ((m
ab60: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
ab70: 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 tconfig "require
ab80: 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 ments" "mode")))
ab90: 0a 09 09 09 20 20 20 20 28 69 66 20 6d 20 28 6d .... (if m (m
aba0: 61 70 20 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f ap string->symbo
abb0: 6c 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 l (string-split
abc0: 6d 29 29 20 27 28 6e 6f 72 6d 61 6c 29 29 29 29 m)) '(normal))))
abd0: 0a 09 20 20 20 20 20 28 69 74 65 6d 6d 61 70 20 .. (itemmap
abe0: 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (configf:loo
abf0: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 kup tconfig "req
ac00: 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d uirements" "item
ac10: 6d 61 70 22 29 29 0a 09 20 20 20 20 20 28 77 61 map")).. (wa
ac20: 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 itons (tests
ac30: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
ac40: 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 aitons test-r
ac50: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 70 ecord)).. (p
ac60: 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 riority (test
ac70: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
ac80: 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d priority test-
ac90: 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 record)).. (
aca0: 69 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 itemdat (tes
acb0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
acc0: 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 -itemdat test
acd0: 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 -record)) ;; ite
ace0: 6d 64 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 mdat can be a st
acf0: 72 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 ring, list or #f
ad00: 0a 09 20 20 20 20 20 28 69 74 65 6d 73 20 20 20 .. (items
ad10: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
ad20: 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 20 20 ueue-get-items
ad30: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
ad40: 29 0a 09 20 20 20 20 20 28 69 74 65 6d 2d 70 61 ).. (item-pa
ad50: 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d th (item-list-
ad60: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
ad70: 09 20 20 20 20 20 28 74 66 75 6c 6c 6e 61 6d 65 . (tfullname
ad80: 20 20 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 (runs:make-fu
ad90: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ll-test-name tes
ada0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
adb0: 29 29 0a 09 20 20 20 20 20 28 6e 65 77 74 61 6c )).. (newtal
adc0: 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 (append ta
add0: 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 l (list hed)))..
ade0: 20 20 20 20 20 28 72 65 67 66 75 6c 6c 20 20 20 (regfull
adf0: 20 20 28 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 (>= (length re
ae00: 67 29 20 72 65 67 6c 65 6e 29 29 0a 09 20 20 20 g) reglen))..
ae10: 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 (num-running (
ae20: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
ae30: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
ae40: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 29 29 run-id run-id)))
ae50: 0a 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e .. (if (> n
ae60: 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 0a 09 20 um-running 0)..
ae70: 20 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 (set! last-time
ae80: 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 63 -some-running (c
ae90: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
aea0: 29 0a 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 ).. (if (>
aeb0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
aec0: 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 73 6f )(+ last-time-so
aed0: 6d 65 2d 72 75 6e 6e 69 6e 67 20 32 34 30 29 29 me-running 240))
aee0: 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
aef0: 73 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 73 2d set! *max-tries-
af00: 68 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 hash* tfullname
af10: 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (+ (hash-table-r
af20: 65 66 2f 64 65 66 61 75 6c 74 20 2a 6d 61 78 2d ef/default *max-
af30: 74 72 69 65 73 2d 68 61 73 68 2a 20 74 66 75 6c tries-hash* tful
af40: 6c 6e 61 6d 65 20 30 29 20 31 29 29 29 0a 09 3b lname 0) 1)))..;
af50: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
af60: 20 22 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 "max-tries-hash
af70: 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d : " (hash-table-
af80: 3e 61 6c 69 73 74 20 2a 6d 61 78 2d 74 72 69 65 >alist *max-trie
af90: 73 2d 68 61 73 68 2a 29 29 0a 0a 09 3b 3b 20 45 s-hash*))...;; E
afa0: 6e 73 75 72 65 20 61 6c 6c 20 74 6f 70 20 6c 65 nsure all top le
afb0: 76 65 6c 20 74 65 73 74 73 20 67 65 74 20 72 65 vel tests get re
afc0: 67 69 73 74 65 72 65 64 2e 20 54 68 69 73 20 77 gistered. This w
afd0: 61 79 20 74 68 65 79 20 73 68 6f 77 20 75 70 20 ay they show up
afe0: 61 73 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 as "NOT_STARTED"
aff0: 20 6f 6e 20 74 68 65 20 64 61 73 68 62 6f 61 72 on the dashboar
b000: 64 0a 09 3b 3b 20 61 6e 64 20 69 74 20 69 73 20 d..;; and it is
b010: 63 6c 65 61 72 20 74 68 65 79 20 2a 73 68 6f 75 clear they *shou
b020: 6c 64 2a 20 68 61 76 65 20 72 75 6e 20 62 75 74 ld* have run but
b030: 20 64 69 64 20 6e 6f 74 2e 0a 09 28 69 66 20 28 did not...(if (
b040: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
b050: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
b060: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
b070: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
b080: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 ame test-name ""
b090: 29 20 23 66 29 29 0a 09 20 20 20 20 28 62 65 67 ) #f)).. (beg
b0a0: 69 6e 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 67 in.. (rmt:g
b0b0: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 eneral-call 'reg
b0c0: 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 ister-test run-i
b0d0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
b0e0: 6d 65 20 22 22 29 0a 09 20 20 20 20 20 20 28 68 me "").. (h
b0f0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
b100: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 est-registry (ru
b110: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
b120: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name
b130: 20 22 22 29 20 27 64 6f 6e 65 29 29 29 0a 09 0a "") 'done)))...
b140: 09 3b 3b 20 46 61 73 74 20 73 6b 69 70 20 6f 66 .;; Fast skip of
b150: 20 74 65 73 74 73 20 74 68 61 74 20 61 72 65 20 tests that are
b160: 61 6c 72 65 61 64 79 20 22 43 4f 4d 50 4c 45 54 already "COMPLET
b170: 45 44 22 20 2d 20 4e 4f 21 20 43 61 6e 6e 6f 74 ED" - NO! Cannot
b180: 20 64 6f 20 74 68 61 74 20 61 73 20 74 68 65 20 do that as the
b190: 69 74 65 6d 73 20 6d 61 79 20 6e 6f 74 20 68 61 items may not ha
b1a0: 76 65 20 62 65 65 6e 20 65 78 70 61 6e 64 65 64 ve been expanded
b1b0: 20 79 65 74 20 3a 28 0a 09 3b 3b 0a 09 28 69 66 yet :(..;;..(if
b1c0: 20 28 6d 65 6d 62 65 72 20 28 68 61 73 68 2d 74 (member (hash-t
b1d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
b1e0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 test-registry t
b1f0: 66 75 6c 6c 6e 61 6d 65 20 23 66 29 20 0a 09 09 fullname #f) ...
b200: 20 20 20 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 '(DONOTRUN r
b210: 65 6d 6f 76 65 64 29 29 20 3b 3b 20 2a 63 6f 6d emoved)) ;; *com
b220: 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 mon:cant-run-sta
b230: 74 65 73 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 43 tes-sym*) ;; '(C
b240: 4f 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 OMPLETED KILLED
b250: 57 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 WAIVED UNKNOWN I
b260: 4e 43 4f 4d 50 4c 45 54 45 29 29 0a 09 20 20 20 NCOMPLETE))..
b270: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
b280: 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 if (runs:lownois
b290: 65 20 28 63 6f 6e 63 20 22 62 65 65 6e 20 6d 61 e (conc "been ma
b2a0: 72 6b 65 64 20 64 6f 20 6e 6f 74 20 72 75 6e 20 rked do not run
b2b0: 22 20 74 66 75 6c 6c 6e 61 6d 65 29 20 36 30 29 " tfullname) 60)
b2c0: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
b2d0: 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 t-info 0 "Skippi
b2e0: 6e 67 20 74 65 73 74 20 22 20 74 66 75 6c 6c 6e ng test " tfulln
b2f0: 61 6d 65 20 22 20 61 73 20 69 74 20 68 61 73 20 ame " as it has
b300: 62 65 65 6e 20 6d 61 72 6b 65 64 20 64 6f 20 6e been marked do n
b310: 6f 74 20 72 75 6e 20 64 75 65 20 74 6f 20 62 65 ot run due to be
b320: 69 6e 67 20 63 6f 6d 70 6c 65 74 65 64 20 6f 72 ing completed or
b330: 20 6e 6f 74 20 72 75 6e 6e 61 62 6c 65 22 29 29 not runnable"))
b340: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 .. (if (or
b350: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
b360: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 )(not (null? reg
b370: 29 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 )))... (loop (r
b380: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
b390: 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 ed tal reg regle
b3a0: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 n regfull)....(r
b3b0: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 uns:queue-next-t
b3c0: 61 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 al tal reg regle
b3d0: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 n regfull)....(r
b3e0: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 uns:queue-next-r
b3f0: 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 eg tal reg regle
b400: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 72 65 n regfull)....re
b410: 72 75 6e 73 29 29 29 29 0a 09 09 20 20 3b 3b 20 runs))))... ;;
b420: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
b430: 63 64 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 cdr tal) reg rer
b440: 75 6e 73 29 29 29 29 0a 0a 09 28 64 65 62 75 67 uns))))...(debug
b450: 3a 70 72 69 6e 74 20 34 20 22 54 4f 50 20 4f 46 :print 4 "TOP OF
b460: 20 4c 4f 4f 50 20 3d 3e 20 22 0a 09 09 20 20 20 LOOP => "...
b470: 20 20 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 "test-name: "
b480: 74 65 73 74 2d 6e 61 6d 65 0a 09 09 20 20 20 20 test-name...
b490: 20 22 5c 6e 20 20 74 65 73 74 2d 72 65 63 6f 72 "\n test-recor
b4a0: 64 20 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 d " test-record
b4b0: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 68 65 64 ... "\n hed
b4c0: 3a 20 20 20 20 20 20 20 20 20 22 20 68 65 64 0a : " hed.
b4d0: 09 09 20 20 20 20 20 22 5c 6e 20 20 69 74 65 6d .. "\n item
b4e0: 64 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d 64 dat: " itemd
b4f0: 61 74 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 at... "\n i
b500: 74 65 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 tems: " it
b510: 65 6d 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 ems... "\n
b520: 69 74 65 6d 2d 70 61 74 68 3a 20 20 20 22 20 69 item-path: " i
b530: 74 65 6d 2d 70 61 74 68 0a 09 09 20 20 20 20 20 tem-path...
b540: 22 5c 6e 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 "\n waitons:
b550: 20 20 22 20 77 61 69 74 6f 6e 73 0a 09 09 20 20 " waitons...
b560: 20 20 20 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 "\n num-retr
b570: 69 65 73 3a 20 22 20 6e 75 6d 2d 72 65 74 72 69 ies: " num-retri
b580: 65 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 74 es... "\n t
b590: 61 6c 3a 20 20 20 20 20 20 20 20 20 22 20 74 61 al: " ta
b5a0: 6c 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 l... "\n re
b5b0: 72 75 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 runs: " rer
b5c0: 75 6e 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 uns... "\n
b5d0: 72 65 67 66 75 6c 6c 3a 20 20 20 20 20 22 20 72 regfull: " r
b5e0: 65 67 66 75 6c 6c 0a 09 09 20 20 20 20 20 22 5c egfull... "\
b5f0: 6e 20 20 72 65 67 6c 65 6e 3a 20 20 20 20 20 20 n reglen:
b600: 22 20 72 65 67 6c 65 6e 0a 09 09 20 20 20 20 20 " reglen...
b610: 22 5c 6e 20 20 6c 65 6e 67 74 68 20 72 65 67 3a "\n length reg:
b620: 20 20 22 20 28 6c 65 6e 67 74 68 20 72 65 67 29 " (length reg)
b630: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 67 ... "\n reg
b640: 3a 20 20 20 20 20 20 20 20 20 22 20 72 65 67 29 : " reg)
b650: 0a 0a 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 ...;; check for
b660: 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d hed in waitons =
b670: 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 > this would be
b680: 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 circular, remove
b690: 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e it and issue an
b6a0: 0a 09 3b 3b 20 65 72 72 6f 72 0a 09 28 69 66 20 ..;; error..(if
b6b0: 28 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d (member test-nam
b6c0: 65 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 e waitons)..
b6d0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
b6e0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
b6f0: 52 4f 52 3a 20 74 65 73 74 20 22 20 74 65 73 74 ROR: test " test
b700: 2d 6e 61 6d 65 20 22 20 68 61 73 20 6c 69 73 74 -name " has list
b710: 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 ed itself as a w
b720: 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f aiton, please co
b730: 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 20 rrect this!")..
b740: 20 20 20 20 20 28 73 65 74 21 20 77 61 69 74 6f (set! waito
b750: 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 n (filter (lambd
b760: 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c a (x)(not (equal
b770: 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 74 6f ? x hed))) waito
b780: 6e 73 29 29 29 29 0a 0a 09 28 63 6f 6e 64 20 0a ns))))...(cond .
b790: 09 20 0a 09 20 3b 3b 20 57 65 20 77 61 6e 74 20 . .. ;; We want
b7a0: 74 6f 20 63 61 74 63 68 20 74 65 73 74 73 20 74 to catch tests t
b7b0: 68 61 74 20 68 61 76 65 20 77 61 69 74 6f 6e 73 hat have waitons
b7c0: 20 74 68 61 74 20 61 72 65 20 4e 4f 54 20 69 6e that are NOT in
b7d0: 20 74 68 65 20 71 75 65 75 65 20 61 6e 64 20 64 the queue and d
b7e0: 69 73 63 61 72 64 20 74 68 65 6d 20 49 46 46 20 iscard them IFF
b7f0: 0a 09 20 3b 3b 20 74 68 65 79 20 68 61 76 65 20 .. ;; they have
b800: 62 65 65 6e 20 74 68 72 6f 75 67 68 20 74 68 65 been through the
b810: 20 77 72 69 6e 67 65 72 20 31 30 20 6f 72 20 6d wringer 10 or m
b820: 6f 72 65 20 74 69 6d 65 73 0a 09 20 28 28 61 6e ore times.. ((an
b830: 64 20 28 6c 69 73 74 3f 20 77 61 69 74 6f 6e 73 d (list? waitons
b840: 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 28 ).. (not (
b850: 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 29 0a null? waitons)).
b860: 09 20 20 20 20 20 20 20 28 3e 20 28 68 61 73 68 . (> (hash
b870: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
b880: 6c 74 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 lt *max-tries-ha
b890: 73 68 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 30 29 sh* tfullname 0)
b8a0: 20 31 30 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 10).. (no
b8b0: 74 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 t (null? (filter
b8c0: 0a 09 09 09 20 20 20 20 6e 75 6d 62 65 72 3f 0a .... number?.
b8d0: 09 09 09 20 20 20 20 28 6d 61 70 20 28 6c 61 6d ... (map (lam
b8e0: 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 bda (waiton)....
b8f0: 09 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f . (if (and (no
b900: 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e t (member waiton
b910: 20 74 61 6c 29 29 20 20 20 20 20 20 20 20 20 20 tal))
b920: 20 20 3b 3b 20 74 68 69 73 20 77 61 69 74 6f 6e ;; this waiton
b930: 20 69 73 20 6e 6f 74 20 69 6e 20 74 68 65 20 6c is not in the l
b940: 69 73 74 20 74 6f 20 62 65 20 74 72 69 65 64 20 ist to be tried
b950: 74 6f 20 72 75 6e 0a 09 09 09 09 09 20 20 20 20 to run......
b960: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 (not (member wai
b970: 74 6f 6e 20 72 65 72 75 6e 73 29 29 29 0a 09 09 ton reruns)))...
b980: 09 09 20 20 20 20 20 20 20 31 0a 09 09 09 09 20 .. 1.....
b990: 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 #f)).....
b9a0: 77 61 69 74 6f 6e 73 29 29 29 29 29 20 3b 3b 20 waitons))))) ;;
b9b0: 63 6f 75 6c 64 20 64 6f 20 74 68 69 73 20 6d 6f could do this mo
b9c0: 72 65 20 65 6c 65 67 61 6e 74 6c 79 20 77 69 74 re elegantly wit
b9d0: 68 20 61 20 6d 61 72 6b 65 72 2e 2e 2e 2e 0a 09 h a marker......
b9e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
b9f0: 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 72 6b 69 "WARNING: Marki
ba00: 6e 67 20 74 65 73 74 20 22 20 74 66 75 6c 6c 6e ng test " tfulln
ba10: 61 6d 65 20 22 20 61 73 20 6e 6f 74 20 72 75 6e ame " as not run
ba20: 6e 61 62 6c 65 2e 20 49 74 20 69 73 20 77 61 69 nable. It is wai
ba30: 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 20 74 68 ting on tests th
ba40: 61 74 20 63 61 6e 6e 6f 74 20 62 65 20 72 75 6e at cannot be run
ba50: 2e 20 47 69 76 69 6e 67 20 75 70 20 6e 6f 77 2e . Giving up now.
ba60: 22 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c ").. (hash-tabl
ba70: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 e-set! test-regi
ba80: 73 74 72 79 20 74 66 75 6c 6c 6e 61 6d 65 20 27 stry tfullname '
ba90: 72 65 6d 6f 76 65 64 29 29 0a 0a 09 20 3b 3b 20 removed))... ;;
baa0: 69 74 65 6d 73 20 69 73 20 23 66 20 74 68 65 6e items is #f then
bab0: 20 74 68 65 20 74 65 73 74 20 69 73 20 6f 6b 20 the test is ok
bac0: 74 6f 20 62 65 20 68 61 6e 64 65 64 20 6f 66 66 to be handed off
bad0: 20 74 6f 20 6c 61 75 6e 63 68 20 28 62 75 74 20 to launch (but
bae0: 6e 6f 74 20 62 65 66 6f 72 65 29 0a 09 20 3b 3b not before).. ;;
baf0: 20 0a 09 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 .. ((not items)
bb00: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
bb10: 2d 69 6e 66 6f 20 34 20 22 4f 55 54 45 52 20 43 -info 4 "OUTER C
bb20: 4f 4e 44 3a 20 28 6e 6f 74 20 69 74 65 6d 73 29 OND: (not items)
bb30: 22 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 ").. (if (and (
bb40: 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 not (tests:match
bb50: 20 74 65 73 74 2d 70 61 74 74 73 20 28 74 65 73 test-patts (tes
bb60: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
bb70: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
bb80: 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 68 ecord) item-path
bb90: 20 72 65 71 75 69 72 65 64 3a 20 72 65 71 75 69 required: requi
bba0: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 red-tests))...
bbb0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
bbc0: 29 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 ))).. (loop
bbd0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
bbe0: 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 al) reg reruns))
bbf0: 0a 09 20 20 28 6c 65 74 20 28 28 6c 6f 6f 70 2d .. (let ((loop-
bc00: 6c 69 73 74 20 28 72 75 6e 73 3a 70 72 6f 63 65 list (runs:proce
bc10: 73 73 2d 65 78 70 61 6e 64 65 64 2d 74 65 73 74 ss-expanded-test
bc20: 73 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 s hed tal reg re
bc30: 72 75 6e 73 20 72 65 67 6c 65 6e 20 72 65 67 66 runs reglen regf
bc40: 75 6c 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ull test-record
bc50: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d runname test-nam
bc60: 65 20 69 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 e item-path jobg
bc70: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
bc80: 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 ent-jobs run-id
bc90: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
bca0: 68 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d h testmode test-
bcb0: 70 61 74 74 73 20 72 65 71 75 69 72 65 64 2d 74 patts required-t
bcc0: 65 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 ests test-regist
bcd0: 72 79 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 ry registry-mute
bce0: 78 20 66 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 x flags keyvals
bcf0: 72 75 6e 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 run-info newtal
bd00: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
bd10: 72 79 20 69 74 65 6d 6d 61 70 29 29 29 0a 09 20 ry itemmap)))..
bd20: 20 20 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 (if loop-list
bd30: 20 28 61 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f (apply loop loo
bd40: 70 2d 6c 69 73 74 29 29 29 29 0a 0a 09 20 3b 3b p-list))))... ;;
bd50: 20 69 74 65 6d 73 20 70 72 6f 63 65 73 73 65 64 items processed
bd60: 20 69 6e 74 6f 20 61 20 6c 69 73 74 20 62 75 74 into a list but
bd70: 20 6e 6f 74 20 63 61 6d 65 20 69 6e 20 61 73 20 not came in as
bd80: 61 20 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 a list been proc
bd90: 65 73 73 65 64 0a 09 20 3b 3b 0a 09 20 28 28 61 essed.. ;;.. ((a
bda0: 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 nd (list? items)
bdb0: 20 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 ;; thus we
bdc0: 6b 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 know our items a
bdd0: 72 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 re already calcu
bde0: 6c 61 74 65 64 0a 09 20 20 20 20 20 20 20 28 6e lated.. (n
bdf0: 6f 74 20 20 20 69 74 65 6d 64 61 74 29 29 20 20 ot itemdat))
be00: 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 ;; and not yet e
be10: 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 xpanded into the
be20: 20 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 list of things
be30: 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 28 64 to be done.. (d
be40: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
be50: 34 20 22 4f 55 54 45 52 20 43 4f 4e 44 3a 20 28 4 "OUTER COND: (
be60: 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 and (list? items
be70: 29 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 29 22 )(not itemdat))"
be80: 29 0a 09 20 20 3b 3b 20 4d 75 73 74 20 64 65 74 ).. ;; Must det
be90: 65 72 6d 69 6e 65 20 69 66 20 74 68 65 20 69 74 ermine if the it
bea0: 65 6d 73 20 6c 69 73 74 20 69 73 20 76 61 6c 69 ems list is vali
beb0: 64 2e 20 44 69 73 63 61 72 64 20 74 68 65 20 74 d. Discard the t
bec0: 65 73 74 20 69 66 20 69 74 20 69 73 20 6e 6f 74 est if it is not
bed0: 2e 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 6c ... (if (and (l
bee0: 69 73 74 3f 20 69 74 65 6d 73 29 0a 09 09 20 20 ist? items)...
bef0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 69 74 65 6d (> (length item
bf00: 73 29 20 30 29 0a 09 09 20 20 20 28 61 6e 64 20 s) 0)... (and
bf10: 28 6c 69 73 74 3f 20 28 63 61 72 20 69 74 65 6d (list? (car item
bf20: 73 29 29 0a 09 09 09 28 3e 20 28 6c 65 6e 67 74 s))....(> (lengt
bf30: 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 30 h (car items)) 0
bf40: 29 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 64 ))... (debug:d
bf50: 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 0a 09 20 ebug-mode 1))..
bf60: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
bf70: 74 20 32 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 t 2 (map (lambda
bf80: 20 28 72 6f 77 29 0a 09 09 09 09 20 20 20 20 28 (row)..... (
bf90: 63 6f 6e 63 20 28 73 74 72 69 6e 67 2d 69 6e 74 conc (string-int
bfa0: 65 72 73 70 65 72 73 65 0a 09 09 09 09 09 20 20 ersperse......
bfb0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 76 (map (lambda (v
bfc0: 61 72 76 61 6c 29 0a 09 09 09 09 09 09 20 20 28 arval)....... (
bfd0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
bfe0: 73 65 20 76 61 72 76 61 6c 20 22 3d 22 29 29 0a se varval "=")).
bff0: 09 09 09 09 09 09 72 6f 77 29 0a 09 09 09 09 09 ......row)......
c000: 20 20 20 22 20 22 29 0a 09 09 09 09 09 20 20 22 " ")...... "
c010: 5c 6e 22 29 29 0a 09 09 09 09 20 20 69 74 65 6d \n"))..... item
c020: 73 29 29 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 s))).. (for-eac
c030: 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6d h.. (lambda (m
c040: 79 2d 69 74 65 6d 64 61 74 29 0a 09 20 20 20 20 y-itemdat)..
c050: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 (let* ((new-tes
c060: 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 t-record (let ((
c070: 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 newrec (make-tes
c080: 74 73 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a ts:testqueue))).
c090: 09 09 09 09 20 20 20 20 20 20 20 28 76 65 63 74 .... (vect
c0a0: 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 65 or-copy! test-re
c0b0: 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 09 cord newrec)....
c0c0: 09 20 20 20 20 20 20 20 6e 65 77 72 65 63 29 29 . newrec))
c0d0: 0a 09 09 20 20 20 20 28 6d 79 2d 69 74 65 6d 2d ... (my-item-
c0e0: 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d path (item-list-
c0f0: 3e 70 61 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 >path my-itemdat
c100: 29 29 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 ))).. (if
c110: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 (tests:match tes
c120: 74 2d 70 61 74 74 73 20 68 65 64 20 6d 79 2d 69 t-patts hed my-i
c130: 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 72 65 tem-path require
c140: 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 d: required-test
c150: 73 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 s) ;; (patt-list
c160: 2d 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 -match my-item-p
c170: 61 74 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 ath item-patts)
c180: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 ;; yes
c190: 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f , we want to pro
c1a0: 63 65 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 cess this item,
c1b0: 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 NOTE: Should not
c1c0: 20 6e 65 65 64 20 74 68 69 73 20 63 68 65 63 6b need this check
c1d0: 20 68 65 72 65 21 0a 09 09 20 20 20 28 6c 65 74 here!... (let
c1e0: 20 28 28 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 ((newtestname (
c1f0: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
c200: 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 6d 79 2d est-name hed my-
c210: 69 74 65 6d 2d 70 61 74 68 29 29 29 20 20 20 20 item-path)))
c220: 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 61 72 ;; test names ar
c230: 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 73 74 e unique on test
c240: 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 0a 09 name/item-path..
c250: 09 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 . (tests:tes
c260: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
c270: 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 ! new-test-r
c280: 65 63 6f 72 64 20 23 66 29 0a 09 09 20 20 20 20 ecord #f)...
c290: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
c2a0: 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 20 20 e-set-itemdat!
c2b0: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
c2c0: 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 20 my-itemdat)...
c2d0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
c2e0: 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 61 ueue-set-item_pa
c2f0: 74 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 th! new-test-rec
c300: 6f 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 ord my-item-path
c310: 29 0a 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 )... (hash-t
c320: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
c330: 65 63 6f 72 64 73 20 6e 65 77 74 65 73 74 6e 61 ecords newtestna
c340: 6d 65 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f me new-test-reco
c350: 72 64 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 rd)... (set!
c360: 20 74 61 6c 20 28 61 70 70 65 6e 64 20 74 61 6c tal (append tal
c370: 20 28 6c 69 73 74 20 6e 65 77 74 65 73 74 6e 61 (list newtestna
c380: 6d 65 29 29 29 29 29 29 29 20 3b 3b 20 73 69 6e me))))))) ;; sin
c390: 63 65 20 74 68 65 73 65 20 61 72 65 20 69 74 65 ce these are ite
c3a0: 6d 69 7a 65 64 20 63 72 65 61 74 65 20 6e 65 77 mized create new
c3b0: 20 74 65 73 74 20 6e 61 6d 65 73 20 74 65 73 74 test names test
c3c0: 6e 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 20 name/itempath..
c3d0: 20 20 69 74 65 6d 73 29 0a 0a 09 20 20 3b 3b 20 items)... ;;
c3e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
c3f0: 6f 20 30 20 22 54 65 73 74 20 22 20 28 74 65 73 o 0 "Test " (tes
c400: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
c410: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
c420: 65 63 6f 72 64 29 20 22 20 69 73 20 69 74 65 6d ecord) " is item
c430: 69 7a 65 64 20 62 75 74 20 68 61 73 20 6e 6f 20 ized but has no
c440: 69 74 65 6d 73 22 29 0a 0a 09 20 20 3b 3b 20 41 items")... ;; A
c450: 74 20 74 68 69 73 20 70 6f 69 6e 74 20 77 65 20 t this point we
c460: 68 61 76 65 20 70 6f 73 73 69 62 6c 79 20 61 64 have possibly ad
c470: 64 65 64 20 69 74 65 6d 73 20 74 6f 20 74 61 6c ded items to tal
c480: 20 62 75 74 20 61 6c 6c 20 6d 75 73 74 20 62 65 but all must be
c490: 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 0a handed off to .
c4a0: 09 20 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 . ;; INNER COND
c4b0: 20 6c 6f 67 69 63 2e 20 49 20 74 68 69 6e 6b 20 logic. I think
c4c0: 6c 6f 6f 70 20 77 69 74 68 6f 75 74 20 72 6f 74 loop without rot
c4d0: 61 74 69 6e 67 20 74 68 65 20 71 75 65 75 65 20 ating the queue
c4e0: 0a 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 68 65 64 .. ;; (loop hed
c4f0: 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 29 tal reg reruns)
c500: 29 0a 09 20 20 3b 3b 20 28 6c 65 74 20 28 28 6e ).. ;; (let ((n
c510: 65 77 74 61 6c 20 28 61 70 70 65 6e 64 20 74 61 ewtal (append ta
c520: 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 20 l (list hed))))
c530: 20 3b 3b 20 57 65 20 73 68 6f 75 6c 64 20 64 69 ;; We should di
c540: 73 63 61 72 64 20 68 65 64 20 61 73 20 69 74 20 scard hed as it
c550: 68 61 73 20 62 65 65 6e 20 65 78 70 61 6e 64 65 has been expande
c560: 64 20 69 6e 74 6f 20 69 74 27 73 20 69 74 65 6d d into it's item
c570: 73 3f 20 59 65 73 2c 20 62 75 74 20 6f 6e 6c 79 s? Yes, but only
c580: 20 69 66 20 74 68 69 73 20 2a 69 73 2a 20 61 6e if this *is* an
c590: 20 69 74 65 6d 69 7a 65 64 20 74 65 73 74 0a 09 itemized test..
c5a0: 20 20 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 72 20 ;; (loop (car
c5b0: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
c5c0: 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 0a al) reg reruns).
c5d0: 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 . (if (null? ta
c5e0: 6c 29 0a 09 20 20 20 20 20 20 23 66 0a 09 20 20 l).. #f..
c5f0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
c600: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 al)(cdr tal) reg
c610: 20 72 65 72 75 6e 73 29 29 29 0a 09 20 20 20 20 reruns)))..
c620: 0a 09 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 69 .. ;; if items i
c630: 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e 65 s a proc then ne
c640: 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 3a ed to run items:
c650: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
c660: 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 6c onfig, get the l
c670: 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 ist and loop ..
c680: 3b 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e 6c 79 ;; - but only
c690: 20 64 6f 20 74 68 61 74 20 69 66 20 72 65 73 6f do that if reso
c6a0: 75 72 63 65 73 20 65 78 69 73 74 20 74 6f 20 6b urces exist to k
c6b0: 69 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f 62 0a ick off the job.
c6c0: 09 20 3b 3b 20 45 58 50 41 4e 44 20 49 54 45 4d . ;; EXPAND ITEM
c6d0: 53 0a 09 20 28 28 6f 72 20 28 70 72 6f 63 65 64 S.. ((or (proced
c6e0: 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 3f 20 ure? items)(eq?
c6f0: 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 6f 63 items 'have-proc
c700: 65 64 75 72 65 29 29 0a 09 20 20 28 6c 65 74 20 edure)).. (let
c710: 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 ((can-run-more
c720: 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d (runs:can-run-
c730: 6d 6f 72 65 2d 74 65 73 74 73 20 72 75 6e 2d 69 more-tests run-i
c740: 64 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 d jobgroup max-c
c750: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 oncurrent-jobs))
c760: 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
c770: 28 6c 69 73 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d (list? can-run-m
c780: 6f 72 65 29 0a 09 09 20 20 20 20 20 28 63 61 72 ore)... (car
c790: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a can-run-more)).
c7a0: 09 09 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 ..(let ((loop-li
c7b0: 73 74 20 28 72 75 6e 73 3a 65 78 70 61 6e 64 2d st (runs:expand-
c7c0: 69 74 65 6d 73 20 68 65 64 20 74 61 6c 20 72 65 items hed tal re
c7d0: 67 20 72 65 72 75 6e 73 20 72 65 67 66 75 6c 6c g reruns regfull
c7e0: 20 6e 65 77 74 61 6c 20 6a 6f 62 67 72 6f 75 70 newtal jobgroup
c7f0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
c800: 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 74 jobs run-id wait
c810: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 65 ons item-path te
c820: 73 74 6d 6f 64 65 20 74 65 73 74 2d 72 65 63 6f stmode test-reco
c830: 72 64 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 rd can-run-more
c840: 69 74 65 6d 73 20 72 75 6e 6e 61 6d 65 20 74 63 items runname tc
c850: 6f 6e 66 69 67 20 72 65 67 6c 65 6e 20 74 65 73 onfig reglen tes
c860: 74 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 2d t-registry test-
c870: 72 65 63 6f 72 64 73 20 69 74 65 6d 6d 61 70 29 records itemmap)
c880: 29 29 0a 09 09 20 20 28 69 66 20 6c 6f 6f 70 2d ))... (if loop-
c890: 6c 69 73 74 0a 09 09 20 20 20 20 20 20 28 61 70 list... (ap
c8a0: 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c 69 ply loop loop-li
c8b0: 73 74 29 29 29 0a 09 09 3b 3b 20 69 66 20 63 61 st)))...;; if ca
c8c0: 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 n't run more jus
c8d0: 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 t loop with next
c8e0: 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a 09 possible test..
c8f0: 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 .(loop (car newt
c900: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal)
c910: 72 65 67 20 72 65 72 75 6e 73 29 29 29 29 0a 09 reg reruns))))..
c920: 20 20 20 20 0a 09 20 3b 3b 20 74 68 69 73 20 63 .. ;; this c
c930: 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 ase should not h
c940: 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 appen, added to
c950: 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 62 help catch any b
c960: 75 67 73 0a 09 20 28 28 61 6e 64 20 28 6c 69 73 ugs.. ((and (lis
c970: 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 64 61 t? items) itemda
c980: 74 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 t).. (debug:pri
c990: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 53 68 6f nt 0 "ERROR: Sho
c9a0: 75 6c 64 20 6e 6f 74 20 68 61 76 65 20 61 20 6c uld not have a l
c9b0: 69 73 74 20 6f 66 20 69 74 65 6d 73 20 69 6e 20 ist of items in
c9c0: 61 20 74 65 73 74 20 61 6e 64 20 74 68 65 20 69 a test and the i
c9d0: 74 65 6d 73 70 61 74 68 20 73 65 74 20 2d 20 70 temspath set - p
c9e0: 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 lease report thi
c9f0: 73 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 s").. (exit 1))
ca00: 0a 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 .. ((not (null?
ca10: 72 65 72 75 6e 73 29 29 0a 09 20 20 28 6c 65 74 reruns)).. (let
ca20: 2a 20 28 28 6e 65 77 6c 73 74 20 28 74 65 73 74 * ((newlst (test
ca30: 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e s:filter-non-run
ca40: 6e 61 62 6c 65 20 72 75 6e 2d 69 64 20 74 61 6c nable run-id tal
ca50: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 20 test-records))
ca60: 3b 3b 20 69 2e 65 2e 20 6e 6f 74 20 46 41 49 4c ;; i.e. not FAIL
ca70: 2c 20 57 41 49 56 45 44 2c 20 49 4e 43 4f 4d 50 , WAIVED, INCOMP
ca80: 4c 45 54 45 2c 20 50 41 53 53 2c 20 4b 49 4c 4c LETE, PASS, KILL
ca90: 45 44 2c 0a 09 09 20 28 6a 75 6e 6b 65 64 20 28 ED,... (junked (
caa0: 6c 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 20 lset-difference
cab0: 65 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 equal? tal newls
cac0: 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 t))).. (debug
cad0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 66 :print-info 4 "f
cae0: 75 6c 6c 20 64 72 6f 70 20 74 68 72 6f 75 67 68 ull drop through
caf0: 2c 20 69 66 20 72 65 72 75 6e 73 20 69 73 20 6c , if reruns is l
cb00: 65 73 73 20 74 68 61 6e 20 31 30 30 20 77 65 20 ess than 100 we
cb10: 77 69 6c 6c 20 66 6f 72 63 65 20 72 65 74 72 79 will force retry
cb20: 20 74 68 65 6d 2c 20 72 65 72 75 6e 73 3d 22 20 them, reruns="
cb30: 72 65 72 75 6e 73 20 22 2c 20 74 61 6c 3d 22 20 reruns ", tal="
cb40: 74 61 6c 29 0a 09 20 20 20 20 28 69 66 20 28 3c tal).. (if (<
cb50: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 6d 61 78 num-retries max
cb60: 2d 72 65 74 72 69 65 73 29 0a 09 09 28 73 65 74 -retries)...(set
cb70: 21 20 6e 65 77 6c 73 74 20 28 61 70 70 65 6e 64 ! newlst (append
cb80: 20 72 65 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 reruns newlst))
cb90: 29 0a 09 20 20 20 20 28 73 65 74 21 20 6e 75 6d ).. (set! num
cba0: 2d 72 65 74 72 69 65 73 20 28 2b 20 6e 75 6d 2d -retries (+ num-
cbb0: 72 65 74 72 69 65 73 20 31 29 29 0a 09 20 20 20 retries 1))..
cbc0: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
cbd0: 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d p! (+ 1 *global-
cbe0: 64 65 6c 74 61 2a 29 29 0a 09 20 20 20 20 28 69 delta*)).. (i
cbf0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 f (not (null? ne
cc00: 77 6c 73 74 29 29 0a 09 09 3b 3b 20 73 69 6e 63 wlst))...;; sinc
cc10: 65 20 72 65 72 75 6e 73 20 68 61 76 65 20 62 65 e reruns have be
cc20: 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 6f 20 en tacked on to
cc30: 6e 65 77 6c 73 74 20 63 72 65 61 74 65 20 6e 65 newlst create ne
cc40: 77 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 6a 75 w reruns from ju
cc50: 6e 6b 65 64 0a 09 09 28 6c 6f 6f 70 20 28 63 61 nked...(loop (ca
cc60: 72 20 6e 65 77 6c 73 74 29 28 63 64 72 20 6e 65 r newlst)(cdr ne
cc70: 77 6c 73 74 29 20 72 65 67 20 28 64 65 6c 65 74 wlst) reg (delet
cc80: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 6e e-duplicates jun
cc90: 6b 65 64 29 29 29 29 29 0a 09 20 28 28 6e 6f 74 ked))))).. ((not
cca0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 (null? tal))..
ccb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
ccc0: 66 6f 20 34 20 22 49 27 6d 20 70 72 65 74 74 79 fo 4 "I'm pretty
ccd0: 20 73 75 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 sure I shouldn'
cce0: 74 20 67 65 74 20 68 65 72 65 2e 22 29 29 0a 09 t get here."))..
ccf0: 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 ((not (null? re
cd00: 67 29 29 20 3b 3b 20 63 6f 75 6c 64 20 77 65 20 g)) ;; could we
cd10: 67 65 74 20 68 65 72 65 20 77 69 74 68 20 6c 65 get here with le
cd20: 66 74 6f 76 65 72 73 3f 0a 09 20 20 28 64 65 62 ftovers?.. (deb
cd30: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
cd40: 22 48 61 76 65 20 6c 65 66 74 6f 76 65 72 73 21 "Have leftovers!
cd50: 22 29 0a 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 ").. (loop (car
cd60: 20 72 65 67 29 28 63 64 72 20 72 65 67 29 20 27 reg)(cdr reg) '
cd70: 28 29 20 72 65 72 75 6e 73 29 29 0a 09 20 28 65 () reruns)).. (e
cd80: 6c 73 65 0a 09 20 20 28 64 65 62 75 67 3a 70 72 lse.. (debug:pr
cd90: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 78 69 74 int-info 4 "Exit
cda0: 69 6e 67 20 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e ing loop with...
cdb0: 5c 6e 20 20 68 65 64 3d 22 20 68 65 64 20 22 5c \n hed=" hed "\
cdc0: 6e 20 20 74 61 6c 3d 22 20 74 61 6c 20 22 5c 6e n tal=" tal "\n
cdd0: 20 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e reruns=" rerun
cde0: 73 29 29 0a 09 20 29 29 29 0a 20 20 20 20 3b 3b s)).. ))). ;;
cdf0: 20 6e 6f 77 20 2a 69 66 2a 20 2d 72 75 6e 2d 77 now *if* -run-w
ce00: 61 69 74 20 77 65 20 77 61 69 74 20 66 6f 72 20 ait we wait for
ce10: 61 6c 6c 20 74 65 73 74 73 20 74 6f 20 62 65 20 all tests to be
ce20: 64 6f 6e 65 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 done. ;; Now
ce30: 77 61 69 74 20 66 6f 72 20 61 6e 79 20 52 55 4e wait for any RUN
ce40: 4e 49 4e 47 20 74 65 73 74 73 20 74 6f 20 63 6f NING tests to co
ce50: 6d 70 6c 65 74 65 20 28 69 66 20 69 6e 20 72 75 mplete (if in ru
ce60: 6e 2d 77 61 69 74 20 6d 6f 64 65 29 0a 20 20 20 n-wait mode).
ce70: 20 28 6c 65 74 20 77 61 69 74 2d 6c 6f 6f 70 20 (let wait-loop
ce80: 28 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 ((num-running
ce90: 20 20 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e (rmt:get-coun
cea0: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
ceb0: 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 for-run-id run-i
cec0: 64 29 29 0a 09 09 20 20 20 20 28 70 72 65 76 2d d))... (prev-
ced0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 29 0a num-running 0)).
cee0: 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a ;; (debug:
cef0: 70 72 69 6e 74 20 30 20 22 6e 75 6d 2d 72 75 6e print 0 "num-run
cf00: 6e 69 6e 67 3d 22 20 6e 75 6d 2d 72 75 6e 6e 69 ning=" num-runni
cf10: 6e 67 20 22 2c 20 70 72 65 76 2d 6e 75 6d 2d 72 ng ", prev-num-r
cf20: 75 6e 6e 69 6e 67 3d 22 20 70 72 65 76 2d 6e 75 unning=" prev-nu
cf30: 6d 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 20 m-running).
cf40: 20 28 69 66 20 28 61 6e 64 20 28 6f 72 20 28 61 (if (and (or (a
cf50: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
cf60: 6e 2d 77 61 69 74 22 29 0a 09 09 20 20 20 28 65 n-wait")... (e
cf70: 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c qual? (configf:l
cf80: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
cf90: 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e 2d 77 * "setup" "run-w
cfa0: 61 69 74 22 29 20 22 79 65 73 22 29 29 0a 09 20 ait") "yes"))..
cfb0: 20 20 20 20 20 20 28 3e 20 6e 75 6d 2d 72 75 6e (> num-run
cfc0: 6e 69 6e 67 20 30 29 29 0a 09 20 20 28 62 65 67 ning 0)).. (beg
cfd0: 69 6e 0a 09 20 20 20 20 3b 3b 20 48 65 72 65 20 in.. ;; Here
cfe0: 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f 6c 64 20 we mark any old
cff0: 64 65 66 75 6e 63 74 20 74 65 73 74 73 20 61 73 defunct tests as
d000: 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 44 6f 20 incomplete. Do
d010: 74 68 69 73 20 65 76 65 72 79 20 66 69 66 74 65 this every fifte
d020: 65 6e 20 6d 69 6e 75 74 65 73 0a 09 20 20 20 20 en minutes..
d030: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
d040: 30 20 22 47 6f 74 20 68 65 72 65 20 65 68 21 20 0 "Got here eh!
d050: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3d 22 20 6e 75 num-running=" nu
d060: 6d 2d 72 75 6e 6e 69 6e 67 20 22 20 28 3e 20 6e m-running " (> n
d070: 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 20 22 20 um-running 0) "
d080: 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 (> num-running 0
d090: 29 29 0a 09 20 20 20 20 28 69 66 20 28 3e 20 28 )).. (if (> (
d0a0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
d0b0: 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 (+ last-time-inc
d0c0: 6f 6d 70 6c 65 74 65 20 39 30 30 29 29 0a 09 09 omplete 900))...
d0d0: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
d0e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
d0f0: 4d 61 72 6b 69 6e 67 20 73 74 75 63 6b 20 74 65 Marking stuck te
d100: 73 74 73 20 61 73 20 49 4e 43 4f 4d 50 4c 45 54 sts as INCOMPLET
d110: 45 20 77 68 69 6c 65 20 77 61 69 74 69 6e 67 20 E while waiting
d120: 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 for run " run-id
d130: 20 22 2e 20 52 75 6e 6e 69 6e 67 20 61 73 20 70 ". Running as p
d140: 69 64 20 22 20 28 63 75 72 72 65 6e 74 2d 70 72 id " (current-pr
d150: 6f 63 65 73 73 2d 69 64 29 20 22 20 6f 6e 20 22 ocess-id) " on "
d160: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
d170: 29 0a 09 09 20 20 28 73 65 74 21 20 6c 61 73 74 )... (set! last
d180: 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 -time-incomplete
d190: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
d1a0: 73 29 29 0a 09 09 20 20 28 72 6d 74 3a 66 69 6e s))... (rmt:fin
d1b0: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
d1c0: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 23 66 29 plete run-id #f)
d1d0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
d1e0: 20 28 65 71 3f 20 6e 75 6d 2d 72 75 6e 6e 69 6e (eq? num-runnin
d1f0: 67 20 70 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 g prev-num-runni
d200: 6e 67 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 ng))...(debug:pr
d210: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 72 75 6e 2d int-info 0 "run-
d220: 77 61 69 74 20 73 70 65 63 69 66 69 65 64 2c 20 wait specified,
d230: 77 61 69 74 69 6e 67 20 6f 6e 20 22 20 6e 75 6d waiting on " num
d240: 2d 72 75 6e 6e 69 6e 67 20 22 20 74 65 73 74 73 -running " tests
d250: 20 69 6e 20 52 55 4e 4e 49 4e 47 2c 20 52 45 4d in RUNNING, REM
d260: 4f 54 45 48 4f 53 54 53 54 41 52 54 20 6f 72 20 OTEHOSTSTART or
d270: 4c 41 55 4e 43 48 45 44 20 73 74 61 74 65 20 61 LAUNCHED state a
d280: 74 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e t " (time->strin
d290: 67 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 g (seconds->loca
d2a0: 6c 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d l-time (current-
d2b0: 73 65 63 6f 6e 64 73 29 29 29 29 29 0a 09 20 20 seconds)))))..
d2c0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
d2d0: 20 31 35 29 0a 09 20 20 20 20 3b 3b 20 28 77 61 15).. ;; (wa
d2e0: 69 74 2d 6c 6f 6f 70 20 28 72 6d 74 3a 67 65 74 it-loop (rmt:get
d2f0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
d300: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ning-for-run-id
d310: 72 75 6e 2d 69 64 29 20 6e 75 6d 2d 72 75 6e 6e run-id) num-runn
d320: 69 6e 67 29 29 29 29 0a 09 20 20 20 20 28 77 61 ing)))).. (wa
d330: 69 74 2d 6c 6f 6f 70 20 28 72 6d 74 3a 67 65 74 it-loop (rmt:get
d340: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
d350: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ning-for-run-id
d360: 72 75 6e 2d 69 64 29 20 6e 75 6d 2d 72 75 6e 6e run-id) num-runn
d370: 69 6e 67 29 29 29 29 0a 20 20 20 20 3b 3b 20 4c ing)))). ;; L
d380: 45 54 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 ET* ((test-recor
d390: 64 0a 20 20 20 20 3b 3b 20 77 65 20 67 65 74 20 d. ;; we get
d3a0: 68 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 here on "drop th
d3b0: 72 6f 75 67 68 22 2e 20 41 6c 6c 20 64 6f 6e 65 rough". All done
d3c0: 21 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 !. (debug:pri
d3d0: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 6c 6c 20 74 nt-info 1 "All t
d3e0: 65 73 74 73 20 6c 61 75 6e 63 68 65 64 22 29 29 ests launched"))
d3f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
d400: 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 :calc-fails prer
d410: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 eqs-not-met). (
d420: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
d430: 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 test).. (and
d440: 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b (vector? test) ;
d450: 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 ; not (string? t
d460: 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 6c 3f est))... (equal?
d470: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
d480: 61 74 65 20 74 65 73 74 29 20 22 43 4f 4d 50 4c ate test) "COMPL
d490: 45 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 20 28 ETED")... (not (
d4a0: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
d4b0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 29 get-status test)
d4c0: 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 41 53 .... '("PAS
d4d0: 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b S" "WARN" "CHECK
d4e0: 22 20 22 57 41 49 56 45 44 22 20 22 53 4b 49 50 " "WAIVED" "SKIP
d4f0: 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 "))))).. prereq
d500: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 s-not-met))..(de
d510: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
d520: 70 72 65 72 65 71 2d 66 61 69 6c 20 70 72 65 72 prereq-fail prer
d530: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 eqs-not-met). (
d540: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
d550: 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 test).. (and
d560: 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b (vector? test) ;
d570: 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 ; not (string? t
d580: 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 6c 3f est))... (equal?
d590: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
d5a0: 61 74 65 20 74 65 73 74 29 20 22 4e 4f 54 5f 53 ate test) "NOT_S
d5b0: 54 41 52 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 TARTED")... (not
d5c0: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
d5d0: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
d5e0: 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 6e t).... '("n
d5f0: 2f 61 22 20 22 4b 45 45 50 5f 54 52 59 49 4e 47 /a" "KEEP_TRYING
d600: 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 "))))).. prereq
d610: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 s-not-met))..(de
d620: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
d630: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
d640: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
d650: 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 6d (filter. (lam
d660: 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 bda (t). (or
d670: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 (not (vector? t
d680: 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 6c )).. (not (equal
d690: 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 ? "COMPLETED" (d
d6a0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
d6b0: 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 72 65 t))))). prere
d6c0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 qs-not-met))..(d
d6d0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
d6e0: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
d6f0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
d700: 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 (filter. (la
d710: 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f mbda (t). (o
d720: 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 r (not (vector?
d730: 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 t)).. (not (equa
d740: 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 l? "COMPLETED" (
d750: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
d760: 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 72 e t))))). prer
d770: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
d780: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c define (runs:cal
d790: 63 2d 72 75 6e 6e 61 62 6c 65 20 70 72 65 72 65 c-runnable prere
d7a0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 qs-not-met). (f
d7b0: 69 6c 74 65 72 20 0a 20 20 20 28 6c 61 6d 62 64 ilter . (lambd
d7c0: 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 20 28 a (t). (or (
d7d0: 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 not (vector? t))
d7e0: 0a 09 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 .. (and (equal?
d7f0: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 28 64 "NOT_STARTED" (d
d800: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
d810: 20 74 29 29 0a 09 20 20 20 20 20 20 28 6d 65 6d t)).. (mem
d820: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
d830: 2d 73 74 61 74 75 73 20 74 29 0a 09 09 09 20 20 -status t)....
d840: 20 20 20 20 27 28 22 6e 2f 61 22 20 22 4b 45 45 '("n/a" "KEE
d850: 50 5f 54 52 59 49 4e 47 22 29 29 29 29 29 0a 20 P_TRYING"))))).
d860: 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 prereqs-not-me
d870: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 t))..(define (ru
d880: 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 ns:pretty-string
d890: 20 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 lst). (map (la
d8a0: 6d 62 64 61 20 28 74 29 0a 09 20 28 69 66 20 28 mbda (t).. (if (
d8b0: 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 not (vector? t))
d8c0: 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a .. (conc t).
d8d0: 09 20 20 20 20 20 28 63 6f 6e 63 20 28 64 62 3a . (conc (db:
d8e0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
d8f0: 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 e t) ":" (db:tes
d900: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 t-get-state t) "
d910: 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d /" (db:test-get-
d920: 73 74 61 74 75 73 20 74 29 29 29 29 0a 20 20 20 status t)))).
d930: 20 20 20 20 6c 73 74 29 29 0a 0a 28 64 65 66 69 lst))..(defi
d940: 6e 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 ne (runs:make-fu
d950: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ll-test-name tes
d960: 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a tname itempath).
d970: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 (if (equal? it
d980: 65 6d 70 61 74 68 20 22 22 29 20 74 65 73 74 6e empath "") testn
d990: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 ame (conc testna
d9a0: 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 29 me "/" itempath)
d9b0: 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 ))..;; parent-te
d9c0: 73 74 20 69 73 20 74 68 65 72 65 20 61 73 20 61 st is there as a
d9d0: 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 placeholder for
d9e0: 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 when parent-tes
d9f0: 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 ts can be run as
da00: 20 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 a setup step.(d
da10: 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 efine (run:test
da20: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 run-id run-info
da30: 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 keyvals runname
da40: 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 test-record flag
da50: 73 20 70 61 72 65 6e 74 2d 74 65 73 74 20 74 65 s parent-test te
da60: 73 74 2d 72 65 67 69 73 74 72 79 20 61 6c 6c 2d st-registry all-
da70: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a tests-registry).
da80: 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 ;; All these v
da90: 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 66 ars might be ref
daa0: 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 74 erenced by the t
dab0: 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 estconfig file r
dac0: 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 eader. (let* ((
dad0: 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 test-name (te
dae0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
daf0: 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 t-testname tes
db00: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
db10: 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 74 st-waitons (test
db20: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
db30: 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d waitons test-
db40: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
db50: 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 3a -conf (tests:
db60: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
db70: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 stconfig test-re
db80: 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 61 cord)).. (itemda
db90: 74 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 t (tests:te
dba0: 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
dbb0: 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f dat test-reco
dbc0: 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 rd)).. (test-pat
dbd0: 68 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 h (hash-table
dbe0: 2d 72 65 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 -ref all-tests-r
dbf0: 65 67 69 73 74 72 79 20 74 65 73 74 2d 6e 61 6d egistry test-nam
dc00: 65 29 29 20 3b 3b 20 28 63 6f 6e 63 20 2a 74 6f e)) ;; (conc *to
dc10: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 ppath* "/tests/"
dc20: 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 test-name)) ;;
dc30: 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a could use tests:
dc40: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 get-testconfig h
dc50: 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 ere ..... (force
dc60: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
dc70: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
dc80: 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 flags "-force" #
dc90: 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 f)).. (rerun
dca0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
dcb0: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
dcc0: 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a s "-rerun" #f)).
dcd0: 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 . (keepgoing
dce0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
dcf0: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
dd00: 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a keepgoing" #f)).
dd10: 09 20 28 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 . (incomplete-ti
dd20: 6d 65 6f 75 74 20 28 73 74 72 69 6e 67 2d 3e 6e meout (string->n
dd30: 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 umber (or (confi
dd40: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
dd50: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 69 gdat* "setup" "i
dd60: 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 6f 75 ncomplete-timeou
dd70: 74 22 29 20 22 78 22 29 29 29 0a 09 20 28 69 74 t") "x"))).. (it
dd80: 65 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 0a em-path "").
dd90: 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 20 . (db
dda0: 23 66 29 0a 09 20 28 66 75 6c 6c 2d 74 65 73 74 #f).. (full-test
ddb0: 2d 6e 61 6d 65 20 23 66 29 29 0a 0a 20 20 20 20 -name #f))..
ddc0: 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 65 6d 64 ;; setting itemd
ddd0: 61 74 20 74 6f 20 61 20 6c 69 73 74 20 69 66 20 at to a list if
dde0: 69 74 20 69 73 20 23 66 0a 20 20 20 20 28 69 66 it is #f. (if
ddf0: 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 73 (not itemdat)(s
de00: 65 74 21 20 69 74 65 6d 64 61 74 20 27 28 29 29 et! itemdat '())
de10: 29 0a 20 20 20 20 28 73 65 74 21 20 69 74 65 6d ). (set! item
de20: 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 -path (item-list
de30: 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 ->path itemdat))
de40: 0a 20 20 20 20 28 73 65 74 21 20 66 75 6c 6c 2d . (set! full-
de50: 74 65 73 74 2d 6e 61 6d 65 20 28 72 75 6e 73 3a test-name (runs:
de60: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
de70: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
de80: 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 64 em-path)). (d
de90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
dea0: 34 0a 09 09 20 20 20 20 20 20 22 5c 6e 54 45 53 4... "\nTES
deb0: 54 4e 41 4d 45 3a 20 22 20 66 75 6c 6c 2d 74 65 TNAME: " full-te
dec0: 73 74 2d 6e 61 6d 65 20 0a 09 09 20 20 20 20 20 st-name ...
ded0: 20 22 5c 6e 20 20 20 74 65 73 74 2d 63 6f 6e 66 "\n test-conf
dee0: 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c ig: " (hash-tabl
def0: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f e->alist test-co
df00: 6e 66 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 nf)... "\n
df10: 20 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 itemdat: " ite
df20: 6d 64 61 74 0a 09 09 20 20 20 20 20 20 29 0a 20 mdat... ).
df30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
df40: 32 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 2 "Attempting to
df50: 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 66 launch test " f
df60: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 29 0a 20 ull-test-name).
df70: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 (setenv "MT_T
df80: 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e EST_NAME" test-n
df90: 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 ame) ;; . (se
dfa0: 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 tenv "MT_ITEMPAT
dfb0: 48 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 H" item-path).
dfc0: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
dfd0: 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d UNNAME" runnam
dfe0: 65 29 0a 20 20 20 20 28 72 75 6e 73 3a 73 65 74 e). (runs:set
dff0: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
e000: 72 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e rs run-id inrunn
e010: 61 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b ame: runname) ;;
e020: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
e030: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
e040: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 ching process.
e050: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
e060: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a ory *toppath*)..
e070: 20 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 ;; Here is w
e080: 68 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 here the test_me
e090: 74 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 ta table is best
e0a0: 20 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 updated. ;;
e0b0: 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 Yes, another use
e0c0: 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 of a global for
e0d0: 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 caching. Need a
e0e0: 20 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 better way?.
e0f0: 20 3b 3b 0a 20 20 20 20 3b 3b 20 54 68 65 72 65 ;;. ;; There
e100: 20 69 73 20 6e 6f 77 20 61 20 73 69 6e 67 6c 65 is now a single
e110: 20 63 61 6c 6c 20 74 6f 20 72 75 6e 73 3a 75 70 call to runs:up
e120: 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 date-all-test_me
e130: 74 61 20 61 6e 64 20 74 68 69 73 20 0a 20 20 20 ta and this .
e140: 20 3b 3b 20 70 65 72 2d 74 65 73 74 20 63 61 6c ;; per-test cal
e150: 6c 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 2e l is not needed.
e160: 20 47 69 76 65 6e 20 74 68 65 20 64 65 6c 69 63 Given the delic
e170: 61 63 79 20 6f 66 20 74 68 65 20 6d 6f 76 65 20 acy of the move
e180: 74 6f 20 0a 20 20 20 20 3b 3b 20 76 31 2e 35 35 to . ;; v1.55
e190: 20 74 68 69 73 20 63 6f 64 65 20 69 73 20 62 65 this code is be
e1a0: 69 6e 67 20 6c 65 66 74 20 69 6e 20 70 6c 61 63 ing left in plac
e1b0: 65 20 66 6f 72 20 74 68 65 20 74 69 6d 65 20 62 e for the time b
e1c0: 65 69 6e 67 2e 0a 20 20 20 20 3b 3b 0a 20 20 20 eing.. ;;.
e1d0: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
e1e0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
e1f0: 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 t *test-meta-upd
e200: 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 ated* test-name
e210: 23 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 #f)). (be
e220: 67 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 gin.. (hash-ta
e230: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d ble-set! *test-m
e240: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
e250: 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 t-name #t).
e260: 20 20 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 (runs:upda
e270: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 te-test_meta tes
e280: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 t-name test-conf
e290: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 ))). . ;;
e2a0: 69 74 65 6d 64 61 74 20 3d 3e 20 28 28 72 69 70 itemdat => ((rip
e2b0: 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 eness "overripe"
e2c0: 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 ) (temperature "
e2d0: 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 cool") (season "
e2e0: 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 6c summer")). (l
e2f0: 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 et* ((new-test-p
e300: 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 ath (string-inte
e310: 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 rsperse (cons te
e320: 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 st-path (map cad
e330: 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 r itemdat)) "/")
e340: 29 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 ).. (test-id
e350: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 (rmt:get-te
e360: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
e370: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
e380: 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 )).. (testdat
e390: 20 20 20 20 20 20 28 69 66 20 74 65 73 74 2d 69 (if test-i
e3a0: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
e3b0: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
e3c0: 64 20 74 65 73 74 2d 69 64 29 20 23 66 29 29 29 d test-id) #f)))
e3d0: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
e3e0: 74 65 73 74 64 61 74 29 0a 09 20 20 28 6c 65 74 testdat).. (let
e3f0: 20 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b loop ().. ;;
e400: 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 ensure that the
e410: 20 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 path exists bef
e420: 6f 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 ore registering
e430: 74 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b the test.. ;;
e440: 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 NOPE: Cannot! D
e450: 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 on't know yet wh
e460: 69 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 ich disk area wi
e470: 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e ll be assigned..
e480: 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 .... ;; (syst
e490: 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 em (conc "mkdir
e4a0: 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 -p " new-test-pa
e4b0: 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 th)).. ;;..
e4c0: 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ;; (open-run-c
e4d0: 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 lose tests:regis
e4e0: 74 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d ter-test db run-
e4f0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
e500: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a m-path).. ;;.
e510: 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 . ;; NB// for
e520: 20 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e the above line.
e530: 20 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 I want the test
e540: 20 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 to be registere
e550: 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 d long before th
e560: 69 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 is routine gets
e570: 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a called!.. ;;.
e580: 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 . (if (not te
e590: 73 74 2d 69 64 29 28 73 65 74 21 20 74 65 73 74 st-id)(set! test
e5a0: 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
e5b0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
e5c0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
e5d0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
e5e0: 20 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 test-id)...(beg
e5f0: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
e600: 69 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 int 2 "WARN: Tes
e610: 74 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 t not pre-create
e620: 64 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 d? test-name=" t
e630: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d est-name ", item
e640: 2d 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 -path=" item-pat
e650: 68 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 h ", run-id=" ru
e660: 6e 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a 67 n-id)... (rmt:g
e670: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 eneral-call 'reg
e680: 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 ister-test run-i
e690: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
e6a0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 me item-path)...
e6b0: 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 (set! test-id
e6c0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
e6d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
e6e0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a e item-path)))).
e6f0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
e700: 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 t-info 4 "test-i
e710: 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 72 d=" test-id ", r
e720: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
e730: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
e740: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
e750: 70 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 path=\"" item-pa
e760: 74 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 73 th "\"").. (s
e770: 65 74 21 20 74 65 73 74 64 61 74 20 28 72 6d 74 et! testdat (rmt
e780: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
e790: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
e7a0: 2d 69 64 29 29 0a 09 20 20 20 20 28 69 66 20 28 -id)).. (if (
e7b0: 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 09 28 not testdat)...(
e7c0: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
e7d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 :print-info 0 "W
e7e0: 41 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 69 ARNING: server i
e7f0: 73 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 74 72 s overloaded, tr
e800: 79 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 6f 6e ying again in on
e810: 65 20 73 65 63 6f 6e 64 22 29 0a 09 09 20 20 28 e second")... (
e820: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
e830: 0a 09 09 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a ... (loop))))).
e840: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 (if (not t
e850: 65 73 74 64 61 74 29 20 3b 3b 20 73 68 6f 75 6c estdat) ;; shoul
e860: 64 20 4e 4f 54 20 68 61 70 70 65 6e 0a 09 20 20 d NOT happen..
e870: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
e880: 45 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f ERROR: failed to
e890: 20 67 65 74 20 74 65 73 74 20 72 65 63 6f 72 64 get test record
e8a0: 20 66 6f 72 20 74 65 73 74 2d 69 64 20 22 20 74 for test-id " t
e8b0: 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 est-id)). (
e8c0: 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 62 set! test-id (db
e8d0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
e8e0: 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 69 66 tdat)). (if
e8f0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
e900: 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 63 68 est-path).. (ch
e910: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 ange-directory t
e920: 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 62 65 est-path).. (be
e930: 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a gin.. (debug:
e940: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 65 print "ERROR: te
e950: 73 74 20 72 75 6e 20 70 61 74 68 20 6e 6f 74 20 st run path not
e960: 63 72 65 61 74 65 64 20 62 65 66 6f 72 65 20 61 created before a
e970: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 75 6e ttempting to run
e980: 20 74 68 65 20 74 65 73 74 2e 20 50 65 72 68 61 the test. Perha
e990: 70 73 20 79 6f 75 20 61 72 65 20 72 75 6e 6e 69 ps you are runni
e9a0: 6e 67 20 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 20 ng -remove-runs
e9b0: 61 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 at the same time
e9c0: 3f 22 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 ?").. (change
e9d0: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
e9e0: 61 74 68 2a 29 29 29 0a 20 20 20 20 20 20 28 63 ath*))). (c
e9f0: 61 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b ase (if force ;;
ea00: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
ea10: 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f -force")...'NOT_
ea20: 53 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 STARTED...(if te
ea30: 73 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 stdat... (str
ea40: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 ing->symbol (tes
ea50: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
ea60: 64 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 dat))... 'fai
ea70: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a led-to-insert)).
ea80: 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 .((failed-to-ins
ea90: 65 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 ert).. (debug:pr
eaa0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 int 0 "ERROR: Fa
eab0: 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 iled to insert t
eac0: 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 he record into t
ead0: 68 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f he db"))..((NOT_
eae0: 53 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 STARTED COMPLETE
eaf0: 44 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 D DELETED).. (le
eb00: 74 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 t ((runflag #f))
eb10: 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 .. (cond..
eb20: 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e ;; -force, run n
eb30: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 o matter what..
eb40: 20 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 (force (set!
eb50: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
eb60: 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 ;; NOT_STARTED
eb70: 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 , run no matter
eb80: 77 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 what.. ((memb
eb90: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
eba0: 74 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 te testdat) '("D
ebb0: 45 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 ELETED" "NOT_STA
ebc0: 52 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e RTED"))(set! run
ebd0: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
ebe0: 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 ; not -rerun and
ebf0: 20 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 PASS, WARN or C
ec00: 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a HECK, do no run.
ec10: 09 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 . ((and (or (
ec20: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 not rerun)...
ec30: 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 keepgoing)...
ec40: 20 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 ;; Require to
ec50: 66 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 force re-run for
ec60: 20 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 COMPLETED or *a
ec70: 6e 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c nything* + PASS,
ec80: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 WARN or CHECK...
ec90: 20 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 (or (member (t
eca0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
ecb0: 65 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 estdat) '("PASS"
ecc0: 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 "WARN" "CHECK"
ecd0: 22 53 4b 49 50 22 20 22 57 41 49 56 45 44 22 29 "SKIP" "WAIVED")
ece0: 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 )... (membe
ecf0: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
ed00: 65 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 e testdat) '("C
ed10: 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 OMPLETED")))) ..
ed20: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
ed30: 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e t-info 2 "runnin
ed40: 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 g test " test-na
ed50: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
ed60: 20 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 " suppressed as
ed70: 20 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 it is " (test:g
ed80: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
ed90: 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a ) " and " (test:
eda0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
edb0: 61 74 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 at)).. (hash
edc0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
edd0: 2d 72 65 67 69 73 74 72 79 20 66 75 6c 6c 2d 74 -registry full-t
ede0: 65 73 74 2d 6e 61 6d 65 20 27 44 4f 4e 4f 54 52 est-name 'DONOTR
edf0: 55 4e 29 20 3b 3b 20 43 4f 4d 50 4c 45 54 45 44 UN) ;; COMPLETED
ee00: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
ee10: 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 nflag #f))..
ee20: 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 ;; -rerun and st
ee30: 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 atus is one of t
ee40: 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e he specifed, run
ee50: 20 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 72 it.. ((and r
ee60: 65 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 erun... (let* (
ee70: 28 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 72 (rerunlst (str
ee80: 69 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 ing-split rerun
ee90: 22 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 2d ",")).... (must-
eea0: 72 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 rerun (member (t
eeb0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
eec0: 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 estdat) rerunlst
eed0: 29 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 )))... (debug
eee0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d :print-info 3 "-
eef0: 72 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 rerun list: " re
ef00: 72 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 run ", test-stat
ef10: 75 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d us: " (test:get-
ef20: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 22 status testdat)"
ef30: 2c 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 , must-rerun: "
ef40: 6d 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 must-rerun)...
ef50: 20 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 must-rerun))..
ef60: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
ef70: 74 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 t-info 2 "Rerun
ef80: 66 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 forced for test
ef90: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
efa0: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
efb0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
efc0: 74 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 t)).. ;; -kee
efd0: 70 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 pgoing, do not r
efe0: 65 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 erun FAIL.. (
eff0: 28 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 (and keepgoing..
f000: 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 . (member (test
f010: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
f020: 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 dat) '("FAIL")))
f030: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
f040: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 flag #f)).. (
f050: 28 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 (and (not rerun)
f060: 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 ... (member (te
f070: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
f080: 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 stdat) '("FAIL"
f090: 22 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 "n/a"))).. (
f0a0: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
f0b0: 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 ).. (else (se
f0c0: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 t! runflag #f)))
f0d0: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
f0e0: 74 20 34 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 t 4 "RUNNING =>
f0f0: 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c runflag: " runfl
f100: 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 ag " STATE: " (t
f110: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
f120: 73 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a stdat) " STATUS:
f130: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
f140: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 tus testdat))..
f150: 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c (if (not runfl
f160: 61 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 ag).. (if
f170: 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 (not parent-test
f180: 29 0a 09 09 20 20 20 28 69 66 20 28 72 75 6e 73 )... (if (runs
f190: 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 :lownoise (conc
f1a0: 22 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 "not starting te
f1b0: 73 74 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 st" full-test-na
f1c0: 6d 65 29 20 36 30 29 0a 09 09 20 20 20 20 20 20 me) 60)...
f1d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
f1e0: 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 "NOTE: Not start
f1f0: 69 6e 67 20 74 65 73 74 20 22 20 66 75 6c 6c 2d ing test " full-
f200: 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 test-name " as i
f210: 74 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 t is state \"" (
f220: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
f230: 65 73 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 estdat) .....
f240: 20 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 "\" and status
f250: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
f260: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c atus testdat) "\
f270: 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 ", use -rerun \"
f280: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
f290: 75 73 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 us testdat).....
f2a0: 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 "\" or -forc
f2b0: 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 e to override"))
f2c0: 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 ).. ;; NOT
f2d0: 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 E: No longer be
f2e0: 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 checking prerequ
f2f0: 69 73 69 74 65 73 20 68 65 72 65 21 20 57 69 6c isites here! Wil
f300: 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 l never get here
f310: 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 unless prereqs
f320: 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 are.. ;;
f330: 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 already met
f340: 2e 0a 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 ... ;; Thi
f350: 73 20 77 6f 75 6c 64 20 62 65 20 61 20 67 72 65 s would be a gre
f360: 61 74 20 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 at place to do t
f370: 68 65 20 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a he process-fork.
f380: 09 20 20 20 20 20 20 20 3b 3b 20 0a 09 20 20 20 . ;; ..
f390: 20 20 20 20 28 6c 65 74 20 28 28 73 6b 69 70 2d (let ((skip-
f3a0: 74 65 73 74 20 20 20 23 66 29 0a 09 09 20 20 20 test #f)...
f3b0: 20 20 28 73 6b 69 70 2d 63 68 65 63 6b 20 20 28 (skip-check (
f3c0: 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 configf:get-sect
f3d0: 69 6f 6e 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 ion test-conf "s
f3e0: 6b 69 70 22 29 29 29 0a 09 09 20 28 63 6f 6e 64 kip")))... (cond
f3f0: 20 0a 09 09 20 20 3b 3b 20 48 61 76 65 20 74 6f ... ;; Have to
f400: 20 63 68 65 63 6b 20 66 6f 72 20 73 6b 69 70 20 check for skip
f410: 63 6f 6e 64 69 74 69 6f 6e 73 2e 20 54 68 69 73 conditions. This
f420: 20 6f 6e 65 20 73 6b 69 70 73 20 69 66 20 74 68 one skips if th
f430: 65 72 65 20 61 72 65 20 73 61 6d 65 2d 6e 61 6d ere are same-nam
f440: 65 64 20 74 65 73 74 73 0a 09 09 20 20 3b 3b 20 ed tests... ;;
f450: 63 75 72 72 65 6e 74 6c 79 20 72 75 6e 6e 69 6e currently runnin
f460: 67 0a 09 09 20 20 28 28 61 6e 64 20 73 6b 69 70 g... ((and skip
f470: 2d 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 69 -check....(confi
f480: 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 gf:lookup test-c
f490: 6f 6e 66 20 22 73 6b 69 70 22 20 22 70 72 65 76 onf "skip" "prev
f4a0: 72 75 6e 6e 69 6e 67 22 29 29 0a 09 09 20 20 20 running"))...
f4b0: 3b 3b 20 72 75 6e 2d 69 64 73 20 3d 20 23 66 20 ;; run-ids = #f
f4c0: 6d 65 61 6e 73 20 2a 61 6c 6c 2a 20 72 75 6e 73 means *all* runs
f4d0: 0a 09 09 20 20 20 28 6c 65 74 20 28 28 72 75 6e ... (let ((run
f4e0: 6e 69 6e 67 2d 74 65 73 74 73 20 28 72 6d 74 3a ning-tests (rmt:
f4f0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
f500: 6e 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 66 75 ns-mindata #f fu
f510: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 ll-test-name '("
f520: 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 RUNNING" "REMOTE
f530: 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e HOSTSTART" "LAUN
f540: 43 48 45 44 22 29 20 27 28 29 20 23 66 29 29 29 CHED") '() #f)))
f550: 0a 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ... (if (not
f560: 20 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 6e 67 2d (null? running-
f570: 74 65 73 74 73 29 29 20 3b 3b 20 68 61 76 65 20 tests)) ;; have
f580: 74 6f 20 73 6b 69 70 20 0a 09 09 09 20 28 73 65 to skip .... (se
f590: 74 21 20 73 6b 69 70 2d 74 65 73 74 20 22 53 6b t! skip-test "Sk
f5a0: 69 70 70 69 6e 67 20 64 75 65 20 74 6f 20 70 72 ipping due to pr
f5b0: 65 76 69 6f 75 73 20 74 65 73 74 73 20 72 75 6e evious tests run
f5c0: 6e 69 6e 67 22 29 29 29 29 0a 09 09 20 20 28 28 ning"))))... ((
f5d0: 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a 09 and skip-check..
f5e0: 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ..(configf:looku
f5f0: 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 p test-conf "ski
f600: 70 22 20 22 66 69 6c 65 65 78 69 73 74 73 22 29 p" "fileexists")
f610: 29 0a 09 09 20 20 20 28 69 66 20 28 66 69 6c 65 )... (if (file
f620: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 66 69 67 -exists? (config
f630: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f f:lookup test-co
f640: 6e 66 20 22 73 6b 69 70 22 20 22 66 69 6c 65 65 nf "skip" "filee
f650: 78 69 73 74 73 22 29 29 0a 09 09 20 20 20 20 20 xists"))...
f660: 20 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 (set! skip-tes
f670: 74 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 6e t (conc "Skippin
f680: 67 20 64 75 65 20 74 6f 20 65 78 69 73 74 61 6e g due to existan
f690: 63 65 20 6f 66 20 66 69 6c 65 20 22 20 28 63 6f ce of file " (co
f6a0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 nfigf:lookup tes
f6b0: 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 t-conf "skip" "f
f6c0: 69 6c 65 65 78 69 73 74 73 22 29 29 29 29 29 29 ileexists"))))))
f6d0: 0a 09 09 20 28 69 66 20 73 6b 69 70 2d 74 65 73 ... (if skip-tes
f6e0: 74 0a 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a t... (begin.
f6f0: 09 09 20 20 20 20 20 20 20 28 6d 74 3a 74 65 73 .. (mt:tes
f700: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
f710: 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
f720: 74 65 73 74 2d 69 64 20 22 43 4f 4d 50 4c 45 54 test-id "COMPLET
f730: 45 44 22 20 22 53 4b 49 50 22 20 73 6b 69 70 2d ED" "SKIP" skip-
f740: 74 65 73 74 29 0a 09 09 20 20 20 20 20 20 20 28 test)... (
f750: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
f760: 20 31 20 22 53 4b 49 50 50 49 4e 47 20 54 65 73 1 "SKIPPING Tes
f770: 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 t " full-test-na
f780: 6d 65 20 22 20 64 75 65 20 74 6f 20 22 20 73 6b me " due to " sk
f790: 69 70 2d 74 65 73 74 29 29 0a 09 09 20 20 20 20 ip-test))...
f7a0: 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 (if (not (launc
f7b0: 68 2d 74 65 73 74 20 74 65 73 74 2d 69 64 20 72 h-test test-id r
f7c0: 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b un-id run-info k
f7d0: 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 eyvals runname t
f7e0: 65 73 74 2d 63 6f 6e 66 20 74 65 73 74 2d 6e 61 est-conf test-na
f7f0: 6d 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 me test-path ite
f800: 6d 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 09 mdat flags))....
f810: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 28 70 (begin.... (p
f820: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 rint "ERROR: Fai
f830: 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 led to launch th
f840: 65 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 e test. Exiting
f850: 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 as soon as possi
f860: 62 6c 65 22 29 0a 09 09 09 20 20 20 28 73 65 74 ble").... (set
f870: 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 ! *globalexitsta
f880: 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 09 20 tus* 1) ;; ....
f890: 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 (process-signa
f8a0: 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 l (current-proce
f8b0: 73 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 ss-id) signal/ki
f8c0: 6c 6c 29 29 29 29 29 29 29 29 0a 09 28 28 4b 49 ll))))))))..((KI
f8d0: 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a LLED) .. (debug:
f8e0: 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 print 1 "NOTE: "
f8f0: 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 full-test-name
f900: 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
f910: 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c ning or was expl
f920: 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 ictly killed, us
f930: 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e e -force to laun
f940: 63 68 20 69 74 2e 22 29 0a 09 20 28 68 61 73 68 ch it.").. (hash
f950: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
f960: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
f970: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
f980: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 ame test-name te
f990: 73 74 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 st-path) 'DONOTR
f9a0: 55 4e 29 29 20 3b 3b 20 4b 49 4c 4c 45 44 29 29 UN)) ;; KILLED))
f9b0: 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d ..((LAUNCHED REM
f9c0: 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e OTEHOSTSTART RUN
f9d0: 4e 49 4e 47 29 20 20 0a 09 20 28 64 65 62 75 67 NING) .. (debug
f9e0: 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 :print 2 "NOTE:
f9f0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 " test-name " is
fa00: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
fa10: 22 29 29 0a 09 3b 3b 20 28 69 66 20 28 3e 20 28 "))..;; (if (> (
fa20: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
fa30: 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 ds)(+ (db:test-g
fa40: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 et-event_time te
fa50: 73 74 64 61 74 29 0a 09 3b 3b 20 09 09 09 20 20 stdat)..;; ...
fa60: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
fa70: 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 t-run_duration t
fa80: 65 73 74 64 61 74 29 29 29 0a 09 3b 3b 20 09 28 estdat)))..;; .(
fa90: 6f 72 20 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 or incomplete-ti
faa0: 6d 65 6f 75 74 0a 09 3b 3b 20 09 20 20 20 20 36 meout..;; . 6
fab0: 30 30 30 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 000)) ;; i.e. no
fac0: 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 update for more
fad0: 20 74 68 61 6e 20 36 30 30 30 20 73 65 63 6f 6e than 6000 secon
fae0: 64 73 0a 09 3b 3b 20 20 20 20 20 20 28 62 65 67 ds..;; (beg
faf0: 69 6e 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 64 in..;; (d
fb00: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
fb10: 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 RNING: Test " te
fb20: 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 st-name " appear
fb30: 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f s to be dead. Fo
fb40: 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 rcing it to stat
fb50: 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 e INCOMPLETE and
fb60: 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 status STUCK/DE
fb70: 41 44 22 29 0a 09 3b 3b 20 20 20 20 20 20 20 20 AD")..;;
fb80: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
fb90: 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 status! run-id t
fba0: 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 est-id "INCOMPLE
fbb0: 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 TE" "STUCK/DEAD"
fbc0: 20 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 20 "" #f))..;;
fbd0: 20 20 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 65 ;; (tests:te
fbe0: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 st-set-status! t
fbf0: 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 est-id "INCOMPLE
fc00: 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 TE" "STUCK/DEAD"
fc10: 20 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 20 "" #f))..;;
fc20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
fc30: 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e "NOTE: " test-n
fc40: 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 ame " is already
fc50: 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 running")))..(e
fc60: 6c 73 65 20 20 20 20 20 20 0a 09 20 28 64 65 62 lse .. (deb
fc70: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
fc80: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
fc90: 6e 63 68 20 74 65 73 74 20 22 20 66 75 6c 6c 2d nch test " full-
fca0: 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 test-name ". Unr
fcb0: 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 20 ecognised state
fcc0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
fcd0: 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 63 e testdat)).. (c
fce0: 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
fcf0: 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 74 bol (test:get-st
fd00: 61 74 65 20 74 65 73 74 64 61 74 29 29 20 0a 09 ate testdat)) ..
fd10: 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 20 49 ((COMPLETED I
fd20: 4e 43 4f 4d 50 4c 45 54 45 29 0a 09 20 20 20 20 NCOMPLETE)..
fd30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
fd40: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
fd50: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
fd60: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
fd70: 6d 65 20 74 65 73 74 2d 70 61 74 68 29 20 27 44 me test-path) 'D
fd80: 4f 4e 4f 54 52 55 4e 29 29 0a 09 20 20 20 28 65 ONOTRUN)).. (e
fd90: 6c 73 65 0a 09 20 20 20 20 28 68 61 73 68 2d 74 lse.. (hash-t
fda0: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
fdb0: 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 egistry (runs:ma
fdc0: 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d ke-full-test-nam
fdd0: 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 e test-name test
fde0: 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e -path) 'DONOTRUN
fdf0: 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ))))))))..;;====
fe00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe40: 3d 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 ==.;; END OF NEW
fe50: 20 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d STUFF.;;=======
fe60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
fea0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 .(define (get-di
feb0: 72 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 r-up-n dir . par
fec0: 61 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 ams) . (let ((d
fed0: 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 parts (string-s
fee0: 70 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 plit dir "/"))..
fef0: 28 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 (count (if (nu
ff00: 6c 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 ll? params) 1 (c
ff10: 61 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 ar params)))).
ff20: 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 (conc "/" (str
ff30: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
ff40: 0a 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 .. (take d
ff50: 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 parts (- (length
ff60: 20 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 dparts) count))
ff70: 0a 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 .. "/"))))
ff80: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
ff90: 72 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 recursive-delete
ffa0: 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 -with-error-msg
ffb0: 72 65 61 6c 2d 64 69 72 29 0a 20 20 28 69 66 20 real-dir). (if
ffc0: 28 3e 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (> (system (conc
ffd0: 20 22 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d "rm -rf " real-
ffe0: 64 69 72 29 29 20 30 29 0a 20 20 20 20 20 20 28 dir)) 0). (
fff0: 62 65 67 69 6e 0a 09 3b 3b 20 46 41 49 4c 45 44 begin..;; FAILED
10000 2c 20 70 6f 73 73 69 62 6c 79 20 64 75 65 20 74 , possibly due t
10010 6f 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 o permissions, d
10020 6f 20 63 68 6d 6f 64 20 61 2b 72 77 78 20 74 68 o chmod a+rwx th
10030 65 6e 20 74 72 79 20 6f 6e 65 20 6d 6f 72 65 20 en try one more
10040 74 69 6d 65 0a 09 28 73 79 73 74 65 6d 20 28 63 time..(system (c
10050 6f 6e 63 20 22 63 68 6d 6f 64 20 2d 52 20 61 2b onc "chmod -R a+
10060 72 77 78 20 22 20 72 65 61 6c 2d 64 69 72 29 29 rwx " real-dir))
10070 0a 09 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d ..(if (> (system
10080 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 (conc "rm -rf "
10090 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 real-dir)) 0)..
100a0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
100b0 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 72 65 0 "ERROR: There
100c0 20 77 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 was a problem r
100d0 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 emoving " real-d
100e0 69 72 20 22 20 77 69 74 68 20 72 6d 20 2d 66 22 ir " with rm -f"
100f0 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
10100 72 75 6e 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 runs:safe-delete
10110 2d 74 65 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 -test-dir real-d
10120 69 72 29 0a 20 20 3b 3b 20 66 69 72 73 74 20 64 ir). ;; first d
10130 65 6c 65 74 65 20 61 6c 6c 20 73 75 62 2d 64 69 elete all sub-di
10140 72 65 63 74 6f 72 69 65 73 0a 20 20 28 64 69 72 rectories. (dir
10150 65 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 ectory-fold .
10160 28 6c 61 6d 62 64 61 20 28 66 20 78 29 0a 20 20 (lambda (f x).
10170 20 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 (let ((fullna
10180 6d 65 20 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 me (conc real-di
10190 72 20 22 2f 22 20 66 29 29 29 0a 20 20 20 20 20 r "/" f))).
101a0 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
101b0 3f 20 66 75 6c 6c 6e 61 6d 65 29 28 72 75 6e 73 ? fullname)(runs
101c0 3a 72 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 :recursive-delet
101d0 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 e-with-error-msg
101e0 20 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 fullname))).
101f0 20 20 28 2b 20 31 20 78 29 29 0a 20 20 20 30 20 (+ 1 x)). 0
10200 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 real-dir). ;; t
10210 68 65 6e 20 66 69 6c 65 73 20 6f 74 68 65 72 20 hen files other
10220 74 68 61 6e 20 2a 74 65 73 74 64 61 74 2e 64 62 than *testdat.db
10230 2a 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 *. (directory-f
10240 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 old . (lambda
10250 28 66 20 78 29 0a 20 20 20 20 20 28 6c 65 74 20 (f x). (let
10260 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 ((fullname (conc
10270 20 72 65 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 real-dir "/" f)
10280 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e )). (if (n
10290 6f 74 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 ot (string-searc
102a0 68 20 28 72 65 67 65 78 70 20 22 74 65 73 74 64 h (regexp "testd
102b0 61 74 2e 64 62 22 29 20 66 29 29 0a 09 20 20 20 at.db") f))..
102c0 28 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d (runs:recursive-
102d0 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f delete-with-erro
102e0 72 2d 6d 73 67 20 66 75 6c 6c 6e 61 6d 65 29 29 r-msg fullname))
102f0 29 0a 20 20 20 20 20 28 2b 20 31 20 78 29 29 0a ). (+ 1 x)).
10300 20 20 20 30 20 72 65 61 6c 2d 64 69 72 29 0a 20 0 real-dir).
10310 20 3b 3b 20 74 68 65 6e 20 74 68 65 20 65 6e 74 ;; then the ent
10320 69 72 65 20 64 69 72 65 63 74 6f 72 79 0a 20 20 ire directory.
10330 28 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d (runs:recursive-
10340 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f delete-with-erro
10350 72 2d 6d 73 67 20 72 65 61 6c 2d 64 69 72 29 29 r-msg real-dir))
10360 0a 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 ..;; Remove runs
10370 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 .;; fields are p
10380 61 73 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 assing in throug
10390 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b h .;; action:.;;
103a0 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 'remove-runs
103b0 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 .;; 'set-stat
103c0 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e e-status.;;.;; N
103d0 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 B// should pass
103e0 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 in keys?.;;.(def
103f0 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 ine (runs:operat
10400 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 e-on action targ
10410 65 74 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 et runnamepatt t
10420 65 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 estpatt #!key (s
10430 74 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 tate #f)(status
10440 23 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 #f)(new-state-st
10450 61 74 75 73 20 23 66 29 28 72 65 6d 6f 76 65 2d atus #f)(remove-
10460 64 61 74 61 2d 6f 6e 6c 79 20 23 66 29 29 0a 20 data-only #f)).
10470 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 (common:clear-c
10480 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 aches) ;; clear
10490 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 all caches. (le
104a0 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
104b0 20 20 23 66 29 0a 09 20 28 74 61 73 6b 73 2d 64 #f).. (tasks-d
104c0 62 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 b (tasks:ope
104d0 6e 2d 64 62 29 29 0a 09 20 28 6b 65 79 73 20 20 n-db)).. (keys
104e0 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d (rmt:get-
104f0 6b 65 79 73 29 29 0a 09 20 28 72 75 6e 64 61 74 keys)).. (rundat
10500 20 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d 72 (mt:get-r
10510 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 73 uns-by-patt keys
10520 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 runnamepatt tar
10530 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 72 20 get)).. (header
10540 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
10550 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 f rundat 0)).. (
10560 72 75 6e 73 20 20 20 20 20 20 20 20 20 28 76 65 runs (ve
10570 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
10580 31 29 29 0a 09 20 28 73 74 61 74 65 73 20 20 20 1)).. (states
10590 20 20 20 20 28 69 66 20 73 74 61 74 65 20 20 28 (if state (
105a0 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 string-split sta
105b0 74 65 20 20 22 2c 22 29 20 27 28 29 29 29 0a 09 te ",") '()))..
105c0 20 28 73 74 61 74 75 73 65 73 20 20 20 20 20 28 (statuses (
105d0 69 66 20 73 74 61 74 75 73 20 28 73 74 72 69 6e if status (strin
105e0 67 2d 73 70 6c 69 74 20 73 74 61 74 75 73 20 22 g-split status "
105f0 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 ,") '())).. (sta
10600 74 65 2d 73 74 61 74 75 73 20 28 69 66 20 28 73 te-status (if (s
10610 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 tring? new-state
10620 2d 73 74 61 74 75 73 29 20 28 73 74 72 69 6e 67 -status) (string
10630 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 -split new-state
10640 2d 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 23 -status ",") '(#
10650 66 20 23 66 29 29 29 29 0a 20 20 20 20 28 64 65 f #f)))). (de
10660 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
10670 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f "runs:operate-o
10680 6e 20 3d 3e 20 48 65 61 64 65 72 3a 20 22 20 68 n => Header: " h
10690 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 eader " action:
106a0 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 " action " new-s
106b0 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 20 6e tate-status: " n
106c0 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 ew-state-status)
106d0 0a 20 20 20 20 28 69 66 20 28 3e 20 32 20 28 6c . (if (> 2 (l
106e0 65 6e 67 74 68 20 73 74 61 74 65 2d 73 74 61 74 ength state-stat
106f0 75 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 us))..(begin..
10700 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
10710 45 52 52 4f 52 3a 20 74 68 65 20 70 61 72 61 6d ERROR: the param
10720 65 74 65 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 eter to -set-sta
10730 74 65 2d 73 74 61 74 75 73 20 69 73 20 61 20 63 te-status is a c
10740 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 65 64 20 73 omma delimited s
10750 74 72 69 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 tring. E.g. COMP
10760 4c 45 54 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 LETED,FAIL")..
10770 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 66 6f (exit))). (fo
10780 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
10790 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 bda (run).
107a0 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 79 20 28 (let ((runkey (
107b0 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
107c0 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 se (map (lambda
107d0 28 6b 29 0a 09 09 09 09 09 09 28 64 62 3a 67 65 (k).......(db:ge
107e0 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
107f0 72 20 72 75 6e 20 68 65 61 64 65 72 20 6b 29 29 r run header k))
10800 20 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 20 20 keys) "/"))..
10810 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f (dirs-to-remo
10820 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ve (make-hash-ta
10830 62 6c 65 29 29 0a 09 20 20 20 20 20 28 70 72 6f ble)).. (pro
10840 63 2d 67 65 74 2d 74 65 73 74 73 20 28 6c 61 6d c-get-tests (lam
10850 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 09 09 bda (run-id)....
10860 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d 74 65 (mt:get-te
10870 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d sts-for-run run-
10880 69 64 0a 09 09 09 09 09 09 20 20 20 20 74 65 73 id....... tes
10890 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
108a0 74 75 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 tuses.......
108b0 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 09 09 not-in: #f.....
108c0 09 09 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 .. sort-by: (
108d0 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 case action.....
108e0 09 09 09 20 20 20 20 20 20 20 28 28 72 65 6d 6f ... ((remo
108f0 76 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 69 72 ve-runs) 'rundir
10900 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 20 )........
10910 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 27 (else '
10920 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 29 29 29 event_time))))))
10930 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 .. (let* ((run-i
10940 64 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c d (db:get-val
10950 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
10960 20 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 header "id"))..
10970 09 28 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a .(run-state (db:
10980 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
10990 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
109a0 73 74 61 74 65 22 29 29 0a 09 09 28 72 75 6e 2d state"))...(run-
109b0 6e 61 6d 65 20 20 28 64 62 3a 67 65 74 2d 76 61 name (db:get-va
109c0 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
109d0 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d n header "runnam
109e0 65 22 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 e"))...(tests
109f0 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa
10a00 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f l? run-state "lo
10a10 63 6b 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 cked"))....
10a20 20 20 28 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 (proc-get-test
10a30 73 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 s run-id)....
10a40 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 '()))...(las
10a50 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f ttpath "/does/no
10a60 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 t/exist/I/hope")
10a70 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
10a80 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
10a90 6f 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 operate-on run="
10aa0 20 72 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 run ", header="
10ab0 20 68 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 header).. (if
10ac0 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
10ad0 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 ts)).. (be
10ae0 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 gin... (case act
10af0 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 ion... ((remov
10b00 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 3b 3b e-runs)... ;;
10b10 20 73 65 65 6b 20 61 6e 64 20 6b 69 6c 6c 20 69 seek and kill i
10b20 6e 20 66 6c 69 67 68 74 20 2d 72 75 6e 74 65 73 n flight -runtes
10b30 74 73 20 77 69 74 68 20 25 20 61 73 20 74 65 73 ts with % as tes
10b40 74 70 61 74 74 20 68 65 72 65 0a 09 09 20 20 20 tpatt here...
10b50 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 65 73 (if (equal? tes
10b60 74 70 61 74 74 20 22 25 22 29 0a 09 09 09 28 74 tpatt "%")....(t
10b70 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 72 asks:kill-runner
10b80 20 74 61 73 6b 73 2d 64 62 20 74 61 72 67 65 74 tasks-db target
10b90 20 72 75 6e 2d 6e 61 6d 65 29 0a 09 09 09 28 64 run-name)....(d
10ba0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 6e 6f ebug:print 0 "no
10bb0 74 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 t attempting to
10bc0 6b 69 6c 6c 20 61 6e 79 20 72 75 6e 20 6c 61 75 kill any run lau
10bd0 6e 63 68 65 72 20 70 72 6f 63 65 73 73 65 73 20 ncher processes
10be0 61 73 20 74 65 73 74 70 61 74 74 20 69 73 20 22 as testpatt is "
10bf0 20 74 65 73 74 70 61 74 74 29 29 0a 09 09 20 20 testpatt))...
10c00 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
10c10 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 "Removing tests
10c20 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b for run: " runk
10c30 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
10c40 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
10c50 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
10c60 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 me")))... ((se
10c70 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a t-state-status).
10c80 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
10c90 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 nt 1 "Modifying
10ca0 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 state and staus
10cb0 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 for tests for ru
10cc0 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
10cd0 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
10ce0 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
10cf0 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a er "runname"))).
10d00 09 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e .. ((print-run
10d10 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
10d20 72 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 rint 1 "Printing
10d30 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 info for run "
10d40 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 runkey ", run="
10d50 72 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 run ", tests=" t
10d60 65 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 ests ", header="
10d70 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 header)... a
10d80 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 28 72 75 ction)... ((ru
10d90 6e 2d 77 61 69 74 29 0a 09 09 20 20 20 20 28 64 n-wait)... (d
10da0 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 61 ebug:print 1 "Wa
10db0 69 74 69 6e 67 20 66 6f 72 20 72 75 6e 20 22 20 iting for run "
10dc0 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 runkey ", run="
10dd0 72 75 6e 6e 61 6d 65 70 61 74 74 20 22 20 74 6f runnamepatt " to
10de0 20 63 6f 6d 70 6c 65 74 65 22 29 29 0a 09 09 20 complete"))...
10df0 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 64 (else... (d
10e00 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
10e10 30 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 72 65 0 "action not re
10e20 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 6f cognised " actio
10e30 6e 29 29 29 0a 09 09 20 28 6c 65 74 20 28 28 73 n)))... (let ((s
10e40 6f 72 74 65 64 2d 74 65 73 74 73 20 20 20 20 20 orted-tests
10e50 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d (sort tests (lam
10e60 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 bda (a b)(let ((
10e70 64 69 72 61 20 3b 3b 20 28 72 6d 74 3a 73 64 62 dira ;; (rmt:sdb
10e80 2d 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 09 -qry 'getstr ...
10e90 09 09 09 09 09 09 09 20 28 64 62 3a 74 65 73 74 ....... (db:test
10ea0 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 20 -get-rundir a))
10eb0 3b 3b 20 29 20 20 3b 3b 20 28 66 69 6c 65 64 62 ;; ) ;; (filedb
10ec0 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 62 2a 20 :get-path *fdb*
10ed0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
10ee0 64 69 72 20 61 29 29 29 0a 09 09 09 09 09 09 09 dir a)))........
10ef0 09 09 28 64 69 72 62 20 3b 3b 20 28 72 6d 74 3a ..(dirb ;; (rmt:
10f00 73 64 62 2d 71 72 79 20 27 67 65 74 73 74 72 20 sdb-qry 'getstr
10f10 0a 09 09 09 09 09 09 09 09 09 20 28 64 62 3a 74 .......... (db:t
10f20 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 est-get-rundir b
10f30 29 29 29 20 3b 3b 20 29 20 3b 3b 20 28 28 66 69 ))) ;; ) ;; ((fi
10f40 6c 65 64 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 ledb:get-path *f
10f50 64 62 2a 20 28 64 62 3a 74 65 73 74 2d 67 65 74 db* (db:test-get
10f60 2d 72 75 6e 64 69 72 20 62 29 29 29 29 0a 09 09 -rundir b))))...
10f70 09 09 09 09 09 09 20 20 20 20 28 69 66 20 28 61 ...... (if (a
10f80 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 69 72 61 nd (string? dira
10f90 29 28 73 74 72 69 6e 67 3f 20 64 69 72 62 29 29 )(string? dirb))
10fa0 0a 09 09 09 09 09 09 09 09 09 28 3e 20 28 73 74 ..........(> (st
10fb0 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 ring-length dira
10fc0 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 )(string-length
10fd0 64 69 72 62 29 29 0a 09 09 09 09 09 09 09 09 09 dirb))..........
10fe0 23 66 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 #f)))))...
10ff0 20 28 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 (toplevel-retri
11000 65 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 es (make-hash-ta
11010 62 6c 65 29 29 20 3b 3b 20 74 72 79 20 74 68 72 ble)) ;; try thr
11020 65 65 20 74 69 6d 65 73 20 74 6f 20 6c 6f 6f 70 ee times to loop
11030 20 74 68 72 6f 75 67 68 20 61 6e 64 20 72 65 6d through and rem
11040 6f 76 65 20 74 6f 70 20 6c 65 76 65 6c 20 74 65 ove top level te
11050 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 74 65 sts... (te
11060 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 20 28 st-retry-time (
11070 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
11080 29 0a 09 09 20 20 20 20 20 20 20 28 61 6c 6c 6f )... (allo
11090 77 2d 72 75 6e 2d 74 69 6d 65 20 20 20 31 30 29 w-run-time 10)
110a0 29 20 3b 3b 20 73 65 63 6f 6e 64 73 20 74 6f 20 ) ;; seconds to
110b0 61 6c 6c 6f 77 20 66 6f 72 20 6b 69 6c 6c 69 6e allow for killin
110c0 67 20 74 65 73 74 73 20 62 65 66 6f 72 65 20 6a g tests before j
110d0 75 73 74 20 62 72 75 74 61 6c 6c 79 20 6b 69 6c ust brutally kil
110e0 6c 69 6e 67 20 27 65 6d 0a 09 09 20 20 20 28 6c ling 'em... (l
110f0 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 20 28 et loop ((test (
11100 63 61 72 20 73 6f 72 74 65 64 2d 74 65 73 74 73 car sorted-tests
11110 29 29 0a 09 09 09 20 20 20 20 20 20 28 74 61 6c )).... (tal
11120 20 20 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 (cdr sorted-te
11130 73 74 73 29 29 29 0a 09 09 20 20 20 20 20 28 6c sts)))... (l
11140 65 74 2a 20 28 28 74 65 73 74 2d 69 64 20 20 20 et* ((test-id
11150 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
11160 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 20 -id test))....
11170 20 20 28 6e 65 77 2d 74 65 73 74 2d 64 61 74 20 (new-test-dat
11180 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
11190 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
111a0 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 20 20 test-id)))...
111b0 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6e 65 (if (not ne
111c0 77 2d 74 65 73 74 2d 64 61 74 29 0a 09 09 09 20 w-test-dat)....
111d0 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
111e0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
111f0 22 45 52 52 4f 52 3a 20 57 65 20 68 61 76 65 20 "ERROR: We have
11200 61 20 74 65 73 74 2d 69 64 20 6f 66 20 22 20 74 a test-id of " t
11210 65 73 74 2d 69 64 20 22 20 62 75 74 20 6e 6f 20 est-id " but no
11220 72 65 63 6f 72 64 20 77 61 73 20 66 6f 75 6e 64 record was found
11230 2e 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 63 6b 69 . NOTE: No locki
11240 6e 67 20 6f 66 20 72 65 63 6f 72 64 73 20 69 73 ng of records is
11250 20 64 6f 6e 65 20 62 65 74 77 65 65 6e 20 70 72 done between pr
11260 6f 63 65 73 73 65 73 2c 20 64 6f 20 6e 6f 74 20 ocesses, do not
11270 73 69 6d 75 6c 74 61 6e 65 6f 75 73 6c 79 20 72 simultaneously r
11280 65 6d 6f 76 65 20 74 68 65 20 73 61 6d 65 20 72 emove the same r
11290 75 6e 20 66 72 6f 6d 20 74 77 6f 20 70 72 6f 63 un from two proc
112a0 65 73 73 65 73 21 22 29 0a 09 09 09 20 20 20 20 esses!")....
112b0 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
112c0 20 74 61 6c 29 29 0a 09 09 09 09 20 28 6c 6f 6f tal))..... (loo
112d0 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
112e0 74 61 6c 29 29 29 29 0a 09 09 09 20 20 20 28 6c tal)))).... (l
112f0 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 et* ((item-path
11300 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
11310 2d 69 74 65 6d 2d 70 61 74 68 20 6e 65 77 2d 74 -item-path new-t
11320 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 20 est-dat)).....
11330 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 20 28 (test-name (
11340 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
11350 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 name new-test-da
11360 74 29 29 0a 09 09 09 09 20 20 28 72 75 6e 2d 64 t))..... (run-d
11370 69 72 20 20 20 20 20 20 20 3b 3b 28 66 69 6c 65 ir ;;(file
11380 64 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 62 db:get-path *fdb
11390 2a 0a 09 09 09 09 20 20 20 3b 3b 20 28 72 6d 74 *..... ;; (rmt
113a0 3a 73 64 62 2d 71 72 79 20 27 67 65 74 69 64 20 :sdb-qry 'getid
113b0 0a 09 09 09 09 20 20 20 28 64 62 3a 74 65 73 74 ..... (db:test
113c0 2d 67 65 74 2d 72 75 6e 64 69 72 20 6e 65 77 2d -get-rundir new-
113d0 74 65 73 74 2d 64 61 74 29 29 20 3b 3b 20 29 20 test-dat)) ;; )
113e0 20 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 ;; run dir is
113f0 20 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 from the link t
11400 72 65 65 0a 09 09 09 09 20 20 28 74 65 73 74 2d ree..... (test-
11410 73 74 61 74 65 20 20 20 20 28 64 62 3a 74 65 73 state (db:tes
11420 74 2d 67 65 74 2d 73 74 61 74 65 20 6e 65 77 2d t-get-state new-
11430 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 test-dat)).....
11440 20 28 74 65 73 74 2d 66 75 6c 6c 6e 20 20 20 20 (test-fulln
11450 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c (db:test-get-ful
11460 6c 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 64 lname new-test-d
11470 61 74 29 29 0a 09 09 09 09 20 20 28 75 6e 61 6d at))..... (unam
11480 65 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 e (db:te
11490 73 74 2d 67 65 74 2d 75 6e 61 6d 65 20 20 20 20 st-get-uname
114a0 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 new-test-dat))..
114b0 09 09 09 20 20 28 74 6f 70 6c 65 76 65 6c 2d 77 ... (toplevel-w
114c0 69 74 68 2d 63 68 69 6c 64 72 65 6e 20 28 61 6e ith-children (an
114d0 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 d (db:test-get-i
114e0 73 2d 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 29 s-toplevel test)
114f0 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 ........ (
11500 3e 20 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c > (rmt:test-topl
11510 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 evel-num-items r
11520 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
11530 20 30 29 29 29 29 0a 09 09 09 20 20 20 20 20 28 0)))).... (
11540 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 20 case action....
11550 20 20 20 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 ((remove-r
11560 75 6e 73 29 0a 09 09 09 09 3b 3b 20 69 66 20 74 uns).....;; if t
11570 68 65 20 74 65 73 74 20 69 73 20 61 20 74 6f 70 he test is a top
11580 6c 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c 64 level-with-child
11590 72 65 6e 20 69 73 73 75 65 20 61 6e 20 65 72 72 ren issue an err
115a0 6f 72 20 61 6e 64 20 64 6f 20 6e 6f 74 20 72 65 or and do not re
115b0 6d 6f 76 65 0a 09 09 09 09 28 69 66 20 74 6f 70 move.....(if top
115c0 6c 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c 64 level-with-child
115d0 72 65 6e 0a 09 09 09 09 20 20 20 20 28 62 65 67 ren..... (beg
115e0 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 in..... (de
115f0 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
11600 4e 49 4e 47 3a 20 73 6b 69 70 70 69 6e 67 20 72 NING: skipping r
11610 65 6d 6f 76 61 6c 20 6f 66 20 22 20 74 65 73 74 emoval of " test
11620 2d 66 75 6c 6c 6e 20 22 20 77 69 74 68 20 72 75 -fulln " with ru
11630 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 n-id " run-id "
11640 61 73 20 69 74 20 68 61 73 20 73 75 62 20 74 65 as it has sub te
11650 73 74 73 22 29 0a 09 09 09 09 20 20 20 20 20 20 sts").....
11660 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
11670 20 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 toplevel-retrie
11680 73 20 74 65 73 74 2d 66 75 6c 6c 6e 20 28 2b 20 s test-fulln (+
11690 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
116a0 64 65 66 61 75 6c 74 20 74 6f 70 6c 65 76 65 6c default toplevel
116b0 2d 72 65 74 72 69 65 73 20 74 65 73 74 2d 66 75 -retries test-fu
116c0 6c 6c 6e 20 30 29 20 31 29 29 0a 09 09 09 09 20 lln 0) 1)).....
116d0 20 20 20 20 20 28 69 66 20 28 3e 20 28 68 61 73 (if (> (has
116e0 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 6f 70 6c h-table-ref topl
116f0 65 76 65 6c 2d 72 65 74 72 69 65 73 20 74 65 73 evel-retries tes
11700 74 2d 66 75 6c 6c 6e 29 20 33 29 0a 09 09 09 09 t-fulln) 3).....
11710 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c . (if (not (nul
11720 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 09 20 20 l? tal))......
11730 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
11740 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 20 3b al)(cdr tal))) ;
11750 3b 20 6e 6f 20 65 6c 73 65 20 63 6c 61 75 73 65 ; no else clause
11760 20 2d 20 64 72 6f 70 20 69 74 20 69 66 20 6e 6f - drop it if no
11770 20 6d 6f 72 65 20 69 6e 20 71 75 65 75 65 20 61 more in queue a
11780 6e 64 20 3e 20 33 20 74 72 69 65 73 0a 09 09 09 nd > 3 tries....
11790 09 09 20 20 28 6c 65 74 20 28 28 6e 65 77 74 61 .. (let ((newta
117a0 6c 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c l (append tal (l
117b0 69 73 74 20 74 65 73 74 29 29 29 29 0a 09 09 09 ist test))))....
117c0 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
117d0 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
117e0 74 61 6c 29 29 29 29 29 20 3b 3b 20 6c 6f 6f 70 tal))))) ;; loop
117f0 20 77 69 74 68 20 74 65 73 74 20 73 74 69 6c 6c with test still
11800 20 69 6e 20 71 75 65 75 65 0a 09 09 09 09 20 20 in queue.....
11810 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
11820 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
11830 69 6e 66 6f 20 30 20 22 74 65 73 74 3a 20 22 20 info 0 "test: "
11840 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 74 65 73 test-name " ites
11850 74 2d 73 74 61 74 65 3a 20 22 20 74 65 73 74 2d t-state: " test-
11860 73 74 61 74 65 29 0a 09 09 09 09 20 20 20 20 20 state).....
11870 20 28 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 (if (member tes
11880 74 2d 73 74 61 74 65 20 28 6c 69 73 74 20 22 52 t-state (list "R
11890 55 4e 4e 49 4e 47 22 20 22 4c 41 55 4e 43 48 45 UNNING" "LAUNCHE
118a0 44 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 D" "REMOTEHOSTST
118b0 41 52 54 22 20 22 4b 49 4c 4c 52 45 51 22 29 29 ART" "KILLREQ"))
118c0 0a 09 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 ...... (begin..
118d0 09 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f 74 .... (if (not
118e0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
118f0 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 /default test-re
11900 74 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 try-time test-fu
11910 6c 6c 6e 20 23 66 29 29 0a 09 09 09 09 09 09 28 lln #f)).......(
11920 62 65 67 69 6e 0a 09 09 09 09 09 09 20 20 3b 3b begin....... ;;
11930 20 77 61 6e 74 20 74 6f 20 73 65 74 20 74 6f 20 want to set to
11940 52 45 4d 4f 56 49 4e 47 20 42 55 54 20 43 41 4e REMOVING BUT CAN
11950 4e 4f 54 20 64 6f 20 69 74 20 68 65 72 65 3f 0a NOT do it here?.
11960 09 09 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 ...... (hash-ta
11970 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
11980 74 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 try-time test-fu
11990 6c 6c 6e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 lln (current-sec
119a0 6f 6e 64 73 29 29 29 29 0a 09 09 09 09 09 20 20 onds))))......
119b0 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 (if (> (- (cur
119c0 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 68 61 rent-seconds)(ha
119d0 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
119e0 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 74 65 73 t-retry-time tes
119f0 74 2d 66 75 6c 6c 6e 29 29 20 61 6c 6c 6f 77 2d t-fulln)) allow-
11a00 72 75 6e 2d 74 69 6d 65 29 0a 09 09 09 09 09 09 run-time).......
11a10 3b 3b 20 54 68 69 73 20 74 65 73 74 20 69 73 20 ;; This test is
11a20 6e 6f 74 20 69 6e 20 61 20 63 6f 72 72 65 63 74 not in a correct
11a30 20 73 74 61 74 65 20 66 6f 72 20 63 6c 65 61 6e state for clean
11a40 69 6e 67 20 75 70 2e 20 4c 65 74 27 73 20 74 72 ing up. Let's tr
11a50 79 20 73 6f 6d 65 20 67 72 61 63 65 66 75 6c 20 y some graceful
11a60 73 68 75 74 64 6f 77 6e 20 73 74 65 70 73 20 66 shutdown steps f
11a70 69 72 73 74 0a 09 09 09 09 09 09 3b 3b 20 53 65 irst.......;; Se
11a80 74 20 74 68 65 20 74 65 73 74 20 74 6f 20 22 4b t the test to "K
11a90 49 4c 4c 52 45 51 22 20 61 6e 64 20 77 61 69 74 ILLREQ" and wait
11aa0 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 74 68 five seconds th
11ab0 65 6e 20 74 72 79 20 61 67 61 69 6e 2e 20 52 65 en try again. Re
11ac0 70 65 61 74 20 75 70 20 74 6f 20 66 69 76 65 20 peat up to five
11ad0 74 69 6d 65 73 20 74 68 65 6e 20 67 69 76 65 0a times then give.
11ae0 09 09 09 09 09 09 3b 3b 20 75 70 20 61 6e 64 20 ......;; up and
11af0 62 6c 6f 77 20 69 74 20 61 77 61 79 2e 0a 09 09 blow it away....
11b00 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 ....(begin......
11b10 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
11b20 30 20 22 57 41 52 4e 49 4e 47 3a 20 63 6f 75 6c 0 "WARNING: coul
11b30 64 20 6e 6f 74 20 67 72 61 63 65 66 75 6c 6c 79 d not gracefully
11b40 20 72 65 6d 6f 76 65 20 74 65 73 74 20 22 20 74 remove test " t
11b50 65 73 74 2d 66 75 6c 6c 6e 20 22 2c 20 74 72 69 est-fulln ", tri
11b60 65 64 20 74 6f 20 6b 69 6c 6c 20 69 74 20 74 6f ed to kill it to
11b70 20 6e 6f 20 61 76 61 69 6c 2e 20 46 6f 72 63 69 no avail. Forci
11b80 6e 67 20 73 74 61 74 65 20 74 6f 20 46 41 49 4c ng state to FAIL
11b90 45 44 4b 49 4c 4c 20 61 6e 64 20 63 6f 6e 74 69 EDKILL and conti
11ba0 6e 75 69 6e 67 22 29 0a 09 09 09 09 09 20 20 20 nuing")......
11bb0 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (mt:test-set-st
11bc0 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
11bd0 20 72 75 6e 2d 69 64 20 28 64 62 3a 74 65 73 74 run-id (db:test
11be0 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 46 -get-id test) "F
11bf0 41 49 4c 45 44 4b 49 4c 4c 22 20 22 6e 2f 61 22 AILEDKILL" "n/a"
11c00 20 23 66 29 0a 09 09 09 09 09 09 20 20 28 74 68 #f)....... (th
11c10 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a read-sleep! 1)).
11c20 09 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ......(begin....
11c30 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 .. (mt:test-s
11c40 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
11c50 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 64 62 by-id run-id (db
11c60 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
11c70 74 29 20 22 4b 49 4c 4c 52 45 51 22 20 22 6e 2f t) "KILLREQ" "n/
11c80 61 22 20 23 66 29 0a 09 09 09 09 09 09 20 20 28 a" #f)....... (
11c90 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
11ca0 29 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 4e ))...... ;; N
11cb0 4f 54 45 3a 20 54 68 69 73 20 69 73 20 73 75 62 OTE: This is sub
11cc0 6f 70 74 69 6d 61 6c 20 61 73 20 74 68 65 20 74 optimal as the t
11cd0 65 73 74 64 61 74 61 20 77 69 6c 6c 20 62 65 20 estdata will be
11ce0 75 73 65 64 20 6c 61 74 65 72 20 61 6e 64 20 74 used later and t
11cf0 68 65 20 73 74 61 74 65 2f 73 74 61 74 75 73 20 he state/status
11d00 6d 61 79 20 68 61 76 65 20 63 68 61 6e 67 65 64 may have changed
11d10 20 2e 2e 2e 0a 09 09 09 09 09 20 20 20 20 28 69 ......... (i
11d20 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
11d30 09 09 09 09 28 6c 6f 6f 70 20 6e 65 77 2d 74 65 ....(loop new-te
11d40 73 74 2d 64 61 74 20 74 61 6c 29 0a 09 09 09 09 st-dat tal).....
11d50 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c ..(loop (car tal
11d60 29 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 )(append tal (li
11d70 73 74 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 st new-test-dat)
11d80 29 29 29 29 0a 09 09 09 09 09 20 20 28 62 65 67 ))))...... (beg
11d90 69 6e 0a 09 09 09 09 09 20 20 20 20 28 72 75 6e in...... (run
11da0 73 3a 72 65 6d 6f 76 65 2d 74 65 73 74 2d 64 69 s:remove-test-di
11db0 72 65 63 74 6f 72 79 20 64 62 20 6e 65 77 2d 74 rectory db new-t
11dc0 65 73 74 2d 64 61 74 20 72 65 6d 6f 76 65 2d 64 est-dat remove-d
11dd0 61 74 61 2d 6f 6e 6c 79 29 0a 09 09 09 09 09 20 ata-only)......
11de0 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
11df0 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 09 09 28 l? tal)).......(
11e00 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
11e10 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 dr tal))))))))..
11e20 09 09 20 20 20 20 20 20 20 28 28 73 65 74 2d 73 .. ((set-s
11e30 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 tate-status)....
11e40 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
11e50 66 6f 20 32 20 22 6e 65 77 20 73 74 61 74 65 20 fo 2 "new state
11e60 22 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 " (car state-sta
11e70 74 75 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 tus) ", new stat
11e80 75 73 20 22 20 28 63 61 64 72 20 73 74 61 74 65 us " (cadr state
11e90 2d 73 74 61 74 75 73 29 29 0a 09 09 09 09 28 6d -status)).....(m
11ea0 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
11eb0 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
11ec0 6e 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 n-id (db:test-ge
11ed0 74 2d 69 64 20 74 65 73 74 29 20 28 63 61 72 20 t-id test) (car
11ee0 73 74 61 74 65 2d 73 74 61 74 75 73 29 28 63 61 state-status)(ca
11ef0 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 dr state-status)
11f00 20 23 66 29 0a 09 09 09 09 28 69 66 20 28 6e 6f #f).....(if (no
11f10 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
11f20 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
11f30 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
11f40 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 28 72 )).... ((r
11f50 75 6e 2d 77 61 69 74 29 0a 09 09 09 09 28 64 65 un-wait).....(de
11f60 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
11f70 20 22 73 74 69 6c 6c 20 77 61 69 74 69 6e 67 2c "still waiting,
11f80 20 22 20 28 6c 65 6e 67 74 68 20 74 65 73 74 73 " (length tests
11f90 29 20 22 20 74 65 73 74 73 20 73 74 69 6c 6c 20 ) " tests still
11fa0 72 75 6e 6e 69 6e 67 22 29 0a 09 09 09 09 28 74 running").....(t
11fb0 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 hread-sleep! 10)
11fc0 0a 09 09 09 09 28 6c 65 74 20 28 28 6e 65 77 2d .....(let ((new-
11fd0 74 65 73 74 73 20 28 70 72 6f 63 2d 67 65 74 2d tests (proc-get-
11fe0 74 65 73 74 73 20 72 75 6e 2d 69 64 29 29 29 0a tests run-id))).
11ff0 09 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f .... (if (null?
12000 20 6e 65 77 2d 74 65 73 74 73 29 0a 09 09 09 09 new-tests).....
12010 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
12020 6e 74 2d 69 6e 66 6f 20 31 20 22 52 75 6e 20 63 nt-info 1 "Run c
12030 6f 6d 70 6c 65 74 65 64 20 61 63 63 6f 72 64 69 ompleted accordi
12040 6e 67 20 74 6f 20 7a 65 72 6f 20 74 65 73 74 73 ng to zero tests
12050 20 6d 61 74 63 68 69 6e 67 20 70 72 6f 76 69 64 matching provid
12060 65 64 20 63 72 69 74 65 72 69 61 2e 22 29 0a 09 ed criteria.")..
12070 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
12080 63 61 72 20 6e 65 77 2d 74 65 73 74 73 29 28 63 car new-tests)(c
12090 64 72 20 6e 65 77 2d 74 65 73 74 73 29 29 29 29 dr new-tests))))
120a0 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 ))))... ))
120b0 29 29 29 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 ))).. ;; remov
120c0 65 20 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 e the run if zer
120d0 6f 20 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 o tests remain..
120e0 20 20 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 (if (eq? acti
120f0 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 on 'remove-runs)
12100 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
12110 72 65 6d 74 65 73 74 73 20 28 6d 74 3a 67 65 74 remtests (mt:get
12120 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 28 -tests-for-run (
12130 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
12140 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
12150 72 20 22 69 64 22 29 20 23 66 20 27 28 22 44 45 r "id") #f '("DE
12160 4c 45 54 45 44 22 29 20 27 28 22 6e 2f 61 22 29 LETED") '("n/a")
12170 20 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 not-in: #t)))..
12180 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d . (if (null? rem
12190 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 tests) ;; no mor
121a0 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e e tests remainin
121b0 67 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 g... (let* (
121c0 28 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 (dparts (string
121d0 2d 73 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 -split lasttpath
121e0 20 22 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 "/")).... (r
121f0 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 unpath (conc "/"
12200 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
12210 65 72 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b erse .......(tak
12220 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e e dparts (- (len
12230 67 74 68 20 64 70 61 72 74 73 29 20 31 29 29 0a gth dparts) 1)).
12240 09 09 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 ......"/"))))...
12250 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
12260 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
12270 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 run: " runkey "
12280 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d " (db:get-value-
12290 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
122a0 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 ader "runname")
122b0 22 20 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 " and related re
122c0 63 6f 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 cord")...
122d0 28 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 (rmt:delete-run
122e0 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 run-id)...
122f0 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 (rmt:delete-old
12300 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 -deleted-test-re
12310 63 6f 72 64 73 29 0a 09 09 20 20 20 20 20 20 20 cords)...
12320 3b 3b 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 ;; (cdb:remote-r
12330 75 6e 20 64 62 3a 73 65 74 2d 76 61 72 20 64 62 un db:set-var db
12340 20 22 44 45 4c 45 54 45 44 5f 54 45 53 54 53 22 "DELETED_TESTS"
12350 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
12360 73 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 s))... ;;
12370 6e 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f need to figure o
12380 75 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 ut the path to t
12390 68 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 he run dir and r
123a0 65 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 emove it if empt
123b0 79 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 y... ;;
123c0 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f (if (null? (glo
123d0 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 b (conc runpath
123e0 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 20 20 "/*")))...
123f0 20 3b 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 ;; (begi
12400 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 n... ;; .
12410 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
12420 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 Removing run dir
12430 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 " runpath)...
12440 20 20 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 ;; . (syste
12450 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d m (conc "rmdir -
12460 70 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a p " runpath)))).
12470 09 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 .. )))))..
12480 20 29 29 0a 20 20 20 20 20 72 75 6e 73 29 0a 20 )). runs).
12490 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 (sqlite3:fina
124a0 6c 69 7a 65 21 20 74 61 73 6b 73 2d 64 62 29 29 lize! tasks-db))
124b0 0a 20 20 23 74 29 0a 0a 28 64 65 66 69 6e 65 20 . #t)..(define
124c0 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d 74 65 73 (runs:remove-tes
124d0 74 2d 64 69 72 65 63 74 6f 72 79 20 64 62 20 74 t-directory db t
124e0 65 73 74 20 72 65 6d 6f 76 65 2d 64 61 74 61 2d est remove-data-
124f0 6f 6e 6c 79 29 0a 20 20 28 6c 65 74 2a 20 28 28 only). (let* ((
12500 72 75 6e 2d 64 69 72 20 20 20 20 20 20 20 28 64 run-dir (d
12510 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
12520 72 20 74 65 73 74 29 29 20 20 20 20 3b 3b 20 72 r test)) ;; r
12530 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 un dir is from t
12540 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 20 28 he link tree.. (
12550 72 65 61 6c 2d 64 69 72 20 20 20 20 20 20 28 69 real-dir (i
12560 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
12570 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 run-dir)....
12580 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
12590 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 e run-dir)....
125a0 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 #f))). (if
125b0 72 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 remove-data-only
125c0 0a 09 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 ..(mt:test-set-s
125d0 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
125e0 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 d (db:test-get-r
125f0 75 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 un_id test)(db:t
12600 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
12610 20 22 43 4c 45 41 4e 49 4e 47 22 20 22 4c 4f 43 "CLEANING" "LOC
12620 4b 45 44 22 20 23 66 29 0a 09 28 6d 74 3a 74 65 KED" #f)..(mt:te
12630 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
12640 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 tus-by-id (db:te
12650 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 65 st-get-run_id te
12660 73 74 29 28 64 62 3a 74 65 73 74 2d 67 65 74 2d st)(db:test-get-
12670 69 64 20 74 65 73 74 29 20 22 52 45 4d 4f 56 49 id test) "REMOVI
12680 4e 47 22 20 22 4c 4f 43 4b 45 44 22 20 23 66 29 NG" "LOCKED" #f)
12690 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
126a0 6e 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 65 6d nt-info 1 "Attem
126b0 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 pting to remove
126c0 22 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 28 " (if real-dir (
126d0 63 6f 6e 63 20 22 20 64 69 72 20 22 20 72 65 61 conc " dir " rea
126e0 6c 2d 64 69 72 20 22 20 61 6e 64 20 22 29 20 22 l-dir " and ") "
126f0 22 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d ") " link " run-
12700 64 69 72 29 0a 20 20 20 20 28 69 66 20 28 61 6e dir). (if (an
12710 64 20 72 65 61 6c 2d 64 69 72 20 0a 09 20 20 20 d real-dir ..
12720 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e (> (string-len
12730 67 74 68 20 72 65 61 6c 2d 64 69 72 29 20 35 29 gth real-dir) 5)
12740 0a 09 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 .. (file-exi
12750 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 29 20 sts? real-dir))
12760 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 63 ;; bad heuristic
12770 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 76 but should prev
12780 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 ent /tmp /home e
12790 74 63 2e 0a 09 28 62 65 67 69 6e 20 3b 3b 20 6c tc...(begin ;; l
127a0 65 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 et* ((realpath (
127b0 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 resolve-pathname
127c0 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 20 20 28 run-dir))).. (
127d0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
127e0 20 31 20 22 52 65 63 75 72 73 69 76 65 6c 79 20 1 "Recursively
127f0 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d removing " real-
12800 64 69 72 29 0a 09 20 20 28 69 66 20 28 66 69 6c dir).. (if (fil
12810 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 e-exists? real-d
12820 69 72 29 0a 09 20 20 20 20 20 20 28 72 75 6e 73 ir).. (runs
12830 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d 74 65 73 :safe-delete-tes
12840 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 72 29 0a t-dir real-dir).
12850 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
12860 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
12870 74 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d test dir " real-
12880 64 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f dir " appears to
12890 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 not exist or is
128a0 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 not readable"))
128b0 29 0a 09 28 69 66 20 72 65 61 6c 2d 64 69 72 20 )..(if real-dir
128c0 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
128d0 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 nt 0 "WARNING: d
128e0 69 72 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d irectory " real-
128f0 64 69 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 dir " does not e
12900 78 69 73 74 22 29 0a 09 20 20 20 20 28 64 65 62 xist").. (deb
12910 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
12920 49 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 64 69 72 ING: no real dir
12930 65 63 74 6f 72 79 20 63 6f 72 72 6f 73 70 6f 6e ectory corrospon
12940 64 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 20 72 ding to link " r
12950 75 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 68 69 6e un-dir ", nothin
12960 67 20 64 6f 6e 65 22 29 29 29 0a 20 20 20 20 28 g done"))). (
12970 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e if (symbolic-lin
12980 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 28 62 65 k? run-dir)..(be
12990 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
129a0 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 6d 6f int-info 1 "Remo
129b0 76 69 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 20 72 ving symlink " r
129c0 75 6e 2d 64 69 72 29 0a 09 20 20 28 68 61 6e 64 un-dir).. (hand
129d0 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 le-exceptions..
129e0 20 20 65 78 6e 0a 09 20 20 20 28 64 65 62 75 67 exn.. (debug
129f0 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
12a00 20 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f Failed to remo
12a10 76 65 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e ve symlink " run
12a20 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e -dir ((condition
12a30 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
12a40 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
12a50 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 ) exn) ", attemp
12a60 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 ting to continue
12a70 22 29 0a 09 20 20 20 28 64 65 6c 65 74 65 2d 66 ").. (delete-f
12a80 69 6c 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 ile run-dir)))..
12a90 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
12aa0 72 75 6e 2d 64 69 72 29 0a 09 20 20 20 20 28 69 run-dir).. (i
12ab0 66 20 28 3e 20 28 64 69 72 65 63 74 6f 72 79 2d f (> (directory-
12ac0 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 66 20 fold (lambda (f
12ad0 78 29 28 2b 20 31 20 78 29 29 20 30 20 72 75 6e x)(+ 1 x)) 0 run
12ae0 2d 64 69 72 29 20 30 29 0a 09 09 28 64 65 62 75 -dir) 0)...(debu
12af0 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
12b00 4e 47 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 NG: refusing to
12b10 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 remove " run-dir
12b20 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 " as it is not
12b30 65 6d 70 74 79 22 29 0a 09 09 28 68 61 6e 64 6c empty")...(handl
12b40 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 e-exceptions...
12b50 65 78 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 exn... (debug:pr
12b60 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 int 0 "ERROR: F
12b70 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 ailed to remove
12b80 64 69 72 65 63 74 6f 72 79 20 22 20 72 75 6e 2d directory " run-
12b90 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d dir ((condition-
12ba0 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
12bb0 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
12bc0 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 exn) ", attempt
12bd0 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 ing to continue"
12be0 29 0a 09 09 20 28 64 65 6c 65 74 65 2d 64 69 72 )... (delete-dir
12bf0 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 ectory run-dir))
12c00 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
12c10 72 75 6e 2d 64 69 72 0a 09 09 20 20 20 20 20 28 run-dir... (
12c20 6e 6f 74 20 28 6d 65 6d 62 65 72 20 72 75 6e 2d not (member run-
12c30 64 69 72 20 28 6c 69 73 74 20 22 6e 2f 61 22 20 dir (list "n/a"
12c40 22 2f 74 6d 70 2f 62 61 64 6e 61 6d 65 22 29 29 "/tmp/badname"))
12c50 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e ))...(debug:prin
12c60 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f t 0 "WARNING: no
12c70 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e t removing " run
12c80 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 69 74 -dir " as it eit
12c90 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 73 her doesn't exis
12ca0 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 79 t or is not a sy
12cb0 6d 6c 69 6e 6b 22 29 0a 09 09 28 64 65 62 75 67 mlink")...(debug
12cc0 3a 70 72 69 6e 74 20 30 20 22 4e 4f 54 45 3a 20 :print 0 "NOTE:
12cd0 74 68 65 20 72 75 6e 20 64 69 72 20 66 6f 72 20 the run dir for
12ce0 74 68 69 73 20 74 65 73 74 20 69 73 20 75 6e 64 this test is und
12cf0 65 66 69 6e 65 64 2e 20 54 65 73 74 20 6d 61 79 efined. Test may
12d00 20 68 61 76 65 20 61 6c 72 65 61 64 79 20 62 65 have already be
12d10 65 6e 20 64 65 6c 65 74 65 64 2e 22 29 29 0a 09 en deleted."))..
12d20 20 20 20 20 29 29 0a 20 20 20 20 3b 3b 20 4f 6e )). ;; On
12d30 6c 79 20 64 65 6c 65 74 65 20 74 68 65 20 72 65 ly delete the re
12d40 63 6f 72 64 73 20 2a 61 66 74 65 72 2a 20 72 65 cords *after* re
12d50 6d 6f 76 69 6e 67 20 74 68 65 20 64 69 72 65 63 moving the direc
12d60 74 6f 72 79 2e 20 49 66 20 74 68 69 6e 67 73 20 tory. If things
12d70 66 61 69 6c 20 77 65 20 68 61 76 65 20 61 20 72 fail we have a r
12d80 65 63 6f 72 64 20 0a 20 20 20 20 28 69 66 20 72 ecord . (if r
12d90 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 0a emove-data-only.
12da0 09 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 .(mt:test-set-st
12db0 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
12dc0 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
12dd0 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 n_id test)(db:te
12de0 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
12df0 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 6e "NOT_STARTED" "n
12e00 2f 61 22 20 23 66 29 0a 09 28 72 6d 74 3a 64 65 /a" #f)..(rmt:de
12e10 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
12e20 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 s (db:test-get-r
12e30 75 6e 5f 69 64 20 74 65 73 74 29 20 28 64 62 3a un_id test) (db:
12e40 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
12e50 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
12e60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12e70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12e80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12e90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
12ea0 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 ;; Routines for
12eb0 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 6e manipulating run
12ec0 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
12ed0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12ee0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12ef0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12f00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 ==========..;; S
12f10 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 ince many calls
12f20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 69 72 65 to a run require
12f30 20 70 72 65 74 74 79 20 6d 75 63 68 20 74 68 65 pretty much the
12f40 20 73 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 same setup .;;
12f50 74 68 69 73 20 77 72 61 70 70 65 72 20 69 73 20 this wrapper is
12f60 75 73 65 64 20 74 6f 20 72 65 64 75 63 65 20 74 used to reduce t
12f70 68 65 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f he replication o
12f80 66 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 f code.(define (
12f90 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c general-run-call
12fa0 20 73 77 69 74 63 68 6e 61 6d 65 20 61 63 74 69 switchname acti
12fb0 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 20 on-desc proc).
12fc0 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 (let ((runname (
12fd0 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
12fe0 20 22 2d 72 75 6e 6e 61 6d 65 22 29 28 61 72 67 "-runname")(arg
12ff0 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn
13000 61 6d 65 22 29 29 29 0a 09 28 74 61 72 67 65 74 ame")))..(target
13010 20 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 (common:args-g
13020 65 74 2d 74 61 72 67 65 74 29 29 29 0a 20 20 20 et-target))).
13030 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f (cond. ((no
13040 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 t target).
13050 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
13060 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 ERROR: Missing r
13070 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 equired paramete
13080 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 r for " switchna
13090 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 me ", you must s
130a0 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 65 pecify the targe
130b0 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 29 t with -target")
130c0 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 . (exit 3))
130d0 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e . ((not runn
130e0 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 ame). (debu
130f0 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
13100 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 : Missing requir
13110 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 ed parameter for
13120 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c " switchname ",
13130 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 you must specif
13140 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 y the run name w
13150 69 74 68 20 2d 72 75 6e 6e 61 6d 65 20 72 75 6e ith -runname run
13160 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 78 name"). (ex
13170 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c 73 it 3)). (els
13180 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 e. (let ((d
13190 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b 65 b #f).. (ke
131a0 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 6e 6f ys #f))..(if (no
131b0 74 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d t (launch:setup-
131c0 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 20 28 for-run)).. (
131d0 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 begin .. (d
131e0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 ebug:print 0 "Fa
131f0 69 6c 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 iled to setup, e
13200 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 xiting")..
13210 28 65 78 69 74 20 31 29 29 29 0a 09 3b 3b 20 28 (exit 1)))..;; (
13220 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
13230 20 22 2d 73 65 72 76 65 72 22 29 0a 09 3b 3b 20 "-server")..;;
13240 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
13250 72 75 6e 20 73 65 72 76 65 72 3a 73 74 61 72 74 run server:start
13260 20 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 db (args:get-ar
13270 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a 09 g "-server")))..
13280 28 73 65 74 21 20 6b 65 79 73 20 28 6b 65 79 73 (set! keys (keys
13290 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c :config-get-fiel
132a0 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 ds *configdat*))
132b0 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 ..;; have enough
132c0 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 to process -tar
132d0 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 get or -reqtarg
132e0 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a here..(if (args:
132f0 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
13300 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 g").. (let* (
13310 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e (runconfigf (con
13320 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 c *toppath* "/r
13330 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
13340 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 ")) ;; DO NOT EV
13350 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 ALUATE ALL ...
13360 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 (runconfig (re
13370 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e ad-config runcon
13380 66 69 67 66 20 23 66 20 23 74 20 65 6e 76 69 72 figf #f #t envir
13390 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 0a 09 on-patt: #f)))..
133a0 20 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d (if (hash-
133b0 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
133c0 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 t runconfig (arg
133d0 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
133e0 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 6b arg") #f)... (k
133f0 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 eys:target-set-a
13400 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 rgs keys (args:g
13410 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
13420 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 ") args:arg-hash
13430 29 0a 09 09 20 20 20 20 0a 09 09 20 20 28 62 65 )... ... (be
13440 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 gin... (debug
13450 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
13460 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 [" (args:get-ar
13470 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d g "-reqtarg") "]
13480 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 not found in "
13490 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 runconfigf)...
134a0 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 (if db (sqlite
134b0 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 3:finalize! db))
134c0 0a 09 09 20 20 20 20 28 65 78 69 74 20 31 29 29 ... (exit 1))
134d0 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 )).. (if (arg
134e0 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
134f0 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 et")...(keys:tar
13500 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 get-set-args key
13510 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 s (args:get-arg
13520 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 "-target" args:a
13530 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 rg-hash) args:ar
13540 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 g-hash)))..(if (
13550 6e 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 not (car *config
13560 69 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 info*)).. (be
13570 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
13580 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
13590 3a 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 : Attempted to "
135a0 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 action-desc " b
135b0 75 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 ut run area conf
135c0 69 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e ig file not foun
135d0 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 d").. (exit
135e0 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 1)).. ;; Ext
135f0 72 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e ract out stuff n
13600 65 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 eeded in most or
13610 20 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 many calls..
13620 20 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 ;; here then ca
13630 6c 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 ll proc.. (le
13640 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 t* ((keyvals
13650 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 (keys:target->ke
13660 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 yval keys target
13670 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 ))).. (proc
13680 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
13690 6b 65 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a keys keyvals))).
136a0 09 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 .(if db (sqlite3
136b0 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a :finalize! db)).
136c0 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 .(set! *didsomet
136d0 68 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a hing* #t))))))..
136e0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
136f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13700 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13710 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13720 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b ========.;; Lock
13730 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d /unlock runs.;;=
13740 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13750 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13770 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13780 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
13790 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b runs:handle-lock
137a0 69 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 ing target keys
137b0 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c runname lock unl
137c0 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 ock user). (let
137d0 2a 20 28 28 64 62 20 20 20 20 20 20 20 23 66 29 * ((db #f)
137e0 0a 09 20 28 72 75 6e 64 61 74 20 20 20 28 6d 74 .. (rundat (mt
137f0 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
13800 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 74 t keys runname t
13810 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 arget)).. (heade
13820 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 r (vector-ref
13830 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 rundat 0)).. (ru
13840 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ns (vector-r
13850 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 ef rundat 1))).
13860 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
13870 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 mbda (run)...(le
13880 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 t ((run-id (db:g
13890 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
138a0 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
138b0 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 6f d")))... (if (o
138c0 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 r lock.... (and
138d0 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 unlock....
138e0 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 (begin..... (p
138f0 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 61 rint "Do you rea
13900 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f lly wish to unlo
13910 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 ck run " run-id
13920 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 "?\n y/n: ")..
13930 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 20 ... (equal? "y"
13940 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
13950 09 09 20 20 20 20 20 20 28 72 6d 74 3a 6c 6f 63 .. (rmt:loc
13960 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e k/unlock-run run
13970 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 -id lock unlock
13980 75 73 65 72 29 0a 09 09 20 20 20 20 20 20 28 64 user)... (d
13990 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
139a0 30 20 22 53 6b 69 70 70 69 6e 67 20 6c 6f 63 6b 0 "Skipping lock
139b0 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 6e /unlock on " run
139c0 2d 69 64 29 29 29 29 0a 09 20 20 20 20 20 20 72 -id)))).. r
139d0 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d uns))).;;=======
139e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
13a20 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b ;; Rollup runs.;
13a30 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
13a40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a70 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 61 =======..;; Upda
13a80 74 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 te the test_meta
13a90 20 74 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 table for this
13aa0 74 65 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 test.(define (ru
13ab0 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
13ac0 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 eta test-name te
13ad0 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 st-conf). (let
13ae0 28 28 63 75 72 72 72 65 63 6f 72 64 20 28 72 6d ((currrecord (rm
13af0 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 t:testmeta-get-r
13b00 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d 65 29 ecord test-name)
13b10 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
13b20 63 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 currrecord)..(be
13b30 67 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 gin.. (set! cur
13b40 72 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 rrecord (make-ve
13b50 63 74 6f 72 20 31 31 20 23 66 29 29 0a 09 20 20 ctor 11 #f))..
13b60 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 61 64 (rmt:testmeta-ad
13b70 64 2d 72 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 d-record test-na
13b80 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 me))). (for-e
13b90 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
13ba0 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 a (key). (
13bb0 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 let* ((idx (cadr
13bc0 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 key)).. (f
13bd0 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 ld (car key))..
13be0 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 (val (conf
13bf0 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 ig-lookup test-c
13c00 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 onf "test_meta"
13c10 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 fld))).. ;; (deb
13c20 75 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a ug:print 5 "idx:
13c30 20 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 " idx " fld: "
13c40 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c fld " val: " val
13c50 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c ).. (if (and val
13c60 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 (not (equal? (v
13c70 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 ector-ref currre
13c80 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 cord idx) val)))
13c90 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
13ca0 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 (print "Up
13cb0 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 dating " test-na
13cc0 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 me " " fld " to
13cd0 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 " val).. (
13ce0 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 rmt:testmeta-upd
13cf0 61 74 65 2d 66 69 65 6c 64 20 74 65 73 74 2d 6e ate-field test-n
13d00 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 ame fld val)))))
13d10 0a 20 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 . '(("author
13d20 22 20 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 " 2)("owner" 3)(
13d30 22 64 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 "description" 4)
13d40 28 22 72 65 76 69 65 77 65 64 22 20 35 29 28 22 ("reviewed" 5)("
13d50 74 61 67 73 22 20 39 29 28 22 6a 6f 62 67 72 6f tags" 9)("jobgro
13d60 75 70 22 20 31 30 29 29 29 29 29 0a 0a 3b 3b 20 up" 10)))))..;;
13d70 55 70 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 Update test_meta
13d80 20 66 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 for all tests.(
13d90 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 define (runs:upd
13da0 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 ate-all-test_met
13db0 61 20 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 a db). (let ((t
13dc0 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 est-names (tests
13dd0 3a 67 65 74 2d 61 6c 6c 29 29 29 20 3b 3b 20 28 :get-all))) ;; (
13de0 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d tests:get-valid-
13df0 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f tests))). (fo
13e00 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
13e10 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 mbda (test-name)
13e20 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
13e30 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 6d 74 test-conf (mt
13e40 3a 6c 61 7a 79 2d 72 65 61 64 2d 74 65 73 74 2d :lazy-read-test-
13e50 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 config test-name
13e60 29 29 29 0a 09 20 28 69 66 20 74 65 73 74 2d 63 ))).. (if test-c
13e70 6f 6e 66 20 28 72 75 6e 73 3a 75 70 64 61 74 65 onf (runs:update
13e80 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d -test_meta test-
13e90 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 name test-conf))
13ea0 29 29 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 )). (hash-ta
13eb0 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 6e 61 ble-keys test-na
13ec0 6d 65 73 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 mes))))..;; This
13ed0 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 could probably
13ee0 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e be refactored in
13ef0 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 to one complex q
13f00 75 65 72 79 20 2e 2e 2e 0a 3b 3b 20 4e 4f 54 20 uery ....;; NOT
13f10 50 4f 52 54 45 44 20 2d 20 44 4f 20 4e 4f 54 20 PORTED - DO NOT
13f20 55 53 45 20 59 45 54 0a 3b 3b 0a 28 64 65 66 69 USE YET.;;.(defi
13f30 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d ne (runs:rollup-
13f40 72 75 6e 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 run keys runname
13f50 20 75 73 65 72 20 6b 65 79 76 61 6c 73 29 0a 20 user keyvals).
13f60 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
13f70 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e "runs:rollup-run
13f80 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 , keys: " keys "
13f90 20 2d 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e -runname " runn
13fa0 61 6d 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 ame " user: " us
13fb0 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 er). (let* ((db
13fc0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
13fd0 29 0a 09 20 3b 3b 20 72 65 67 69 73 74 65 72 20 ).. ;; register
13fe0 72 75 6e 20 6f 70 65 72 61 74 65 73 20 6f 6e 20 run operates on
13ff0 74 68 65 20 6d 61 69 6e 20 64 62 0a 09 20 28 6e the main db.. (n
14000 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 ew-run-id (
14010 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e rmt:register-run
14020 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 keyvals runname
14030 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 "new" "n/a" use
14040 72 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 r)).. (prev-test
14050 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d s (rmt:get-
14060 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 matching-previou
14070 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
14080 64 73 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 ds new-run-id "%
14090 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 2d " "%")).. (curr-
140a0 74 65 73 74 73 20 20 20 20 20 20 28 6d 74 3a 67 tests (mt:g
140b0 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
140c0 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 new-run-id "%/%
140d0 22 20 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 " '() '())).. (c
140e0 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 urr-tests-hash (
140f0 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
14100 29 29 0a 20 20 20 20 28 72 6d 74 3a 75 70 64 61 )). (rmt:upda
14110 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d te-run-event_tim
14120 65 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 e new-run-id).
14130 20 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 ;; index the a
14140 6c 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 lready saved tes
14150 74 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 ts by testname a
14160 6e 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 nd itemdat in cu
14170 72 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 rr-tests-hash.
14180 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
14190 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 (lambda (testda
141a0 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t). (let*
141b0 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a ((testname (db:
141c0 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
141d0 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 e testdat))..
141e0 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 (item-path (d
141f0 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
14200 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 path testdat))..
14210 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 (full-name
14220 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 (conc testname
14230 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
14240 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
14250 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 et! curr-tests-h
14260 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 ash full-name te
14270 73 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 stdat))). cu
14280 72 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b rr-tests). ;;
14290 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d NOPE: Non-optim
142a0 61 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 al approach. Try
142b0 20 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 this instead..
142c0 20 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 ;; 1. tests
142d0 20 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e are received in
142e0 20 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 a list, most re
142f0 63 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b cent first. ;
14300 3b 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 ; 2. replace t
14310 68 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 he rollup test w
14320 69 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 ith the new *alw
14330 61 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 ays*. (for-ea
14340 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
14350 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 (testdat).
14360 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 (let* ((testna
14370 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 me (db:test-get
14380 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 -testname testda
14390 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d t)).. (item
143a0 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
143b0 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
143c0 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 tdat)).. (f
143d0 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 ull-name (conc t
143e0 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d estname "/" item
143f0 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 -path)).. (
14400 70 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 prev-test-dat (h
14410 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
14420 66 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 fault curr-tests
14430 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
14440 23 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 #f)).. (tes
14450 74 2d 73 74 65 70 73 20 20 20 20 28 72 6d 74 3a t-steps (rmt:
14460 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
14470 73 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d st (db:test-get-
14480 69 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 id testdat)))..
14490 20 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 (new-test-r
144a0 65 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 ecord #f)).. ;;
144b0 72 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 replace these wi
144c0 74 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 th insert ... se
144d0 6c 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 lect.. (apply sq
144e0 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 lite3:execute ..
144f0 09 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e .db ...(conc "IN
14500 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
14510 49 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f INTO tests (run_
14520 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 id,testname,stat
14530 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 e,status,event_t
14540 69 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 ime,host,cpuload
14550 2c 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c ,diskfree,uname,
14560 72 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 rundir,item_path
14570 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 ,run_duration,fi
14580 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 nal_logf,comment
14590 29 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c ) "... "VAL
145a0 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f UES (?,?,?,?,?,?
145b0 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
145c0 29 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 );")...new-run-i
145d0 64 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d d (cddr (vector-
145e0 3e 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 29 >list testdat)))
145f0 0a 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 .. (set! new-tes
14600 74 64 61 74 20 28 63 61 72 20 28 6d 74 3a 67 65 tdat (car (mt:ge
14610 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
14620 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 new-run-id (conc
14630 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
14640 65 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 em-path) '() '()
14650 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c ))).. (hash-tabl
14660 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 e-set! curr-test
14670 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 s-hash full-name
14680 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b new-testdat) ;;
14690 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 this could be c
146a0 6f 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 onfusing, which
146b0 72 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f record should go
146c0 20 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 into the lookup
146d0 20 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 table?.. ;; Now
146e0 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 duplicate the t
146f0 65 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 est steps.. (deb
14700 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 ug:print 4 "Copy
14710 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 ing records in t
14720 65 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 est_steps from t
14730 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 est_id=" (db:tes
14740 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
14750 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 ) " to " (db:tes
14760 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
14770 74 64 61 74 29 29 0a 09 20 28 63 64 62 3a 72 65 tdat)).. (cdb:re
14780 6d 6f 74 65 2d 72 75 6e 20 0a 09 20 20 28 6c 61 mote-run .. (la
14790 6d 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 mbda ().. (sq
147a0 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 lite3:execute ..
147b0 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 db .. (
147c0 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
147d0 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
147e0 74 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 t_steps (test_id
147f0 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c ,stepname,state,
14800 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d status,event_tim
14810 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 e,comment) "...
14820 20 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a "SELECT " (db:
14830 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
14840 74 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e testdat) ",stepn
14850 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
14860 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d ,event_time,comm
14870 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 ent FROM test_st
14880 65 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 eps WHERE test_i
14890 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 d=?;").. (db
148a0 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
148b0 74 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e tdat)).. ;; N
148c0 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 ow duplicate the
148d0 20 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 test data..
148e0 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
148f0 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 Copying records
14900 69 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f in test_data fro
14910 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a m test_id=" (db:
14920 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
14930 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a dat) " to " (db:
14940 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
14950 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 testdat)).. (
14960 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
14970 0a 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 .. db ..
14980 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f (conc "INSERT O
14990 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 R REPLACE INTO t
149a0 65 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 est_data (test_i
149b0 64 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 d,category,varia
149c0 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 ble,value,expect
149d0 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d ed,tol,units,com
149e0 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 ment) "... "SE
149f0 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d LECT " (db:test-
14a00 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
14a10 61 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 at) ",category,v
14a20 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 ariable,value,ex
14a30 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 pected,tol,units
14a40 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 ,comment FROM te
14a50 73 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 st_data WHERE te
14a60 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 st_id=?;")..
14a70 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
14a80 20 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 testdat)))).. )
14a90 29 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 ). prev-test
14aa0 73 29 29 29 0a 09 20 0a 20 20 20 20 20 0a s))).. . .