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 73 69 67 6e 61 6c m).... (signal
2600: 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a 09 -mask! signum)..
2610: 09 09 20 20 20 28 6c 65 74 20 28 28 74 64 62 20 .. (let ((tdb
2620: 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 (tasks:open-db))
2630: 29 0a 09 09 09 20 20 20 20 20 28 74 61 73 6b 73 ).... (tasks
2640: 3a 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e :set-state-given
2650: 2d 70 61 72 61 6d 2d 6b 65 79 20 74 64 62 20 74 -param-key tdb t
2660: 61 73 6b 2d 6b 65 79 20 22 6b 69 6c 6c 65 64 22 ask-key "killed"
2670: 29 0a 09 09 09 20 20 20 20 20 3b 3b 20 28 73 71 ).... ;; (sq
2680: 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 70 74 21 lite3:interrupt!
2690: 20 74 64 62 29 20 3b 3b 20 73 65 65 6d 73 20 73 tdb) ;; seems s
26a0: 69 6c 6c 79 3f 0a 09 09 09 20 20 20 20 20 28 73 illy?.... (s
26b0: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
26c0: 20 74 64 62 29 29 0a 09 09 09 20 20 20 28 70 72 tdb)).... (pr
26d0: 69 6e 74 20 22 4b 69 6c 6c 65 64 20 62 79 20 73 int "Killed by s
26e0: 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
26f0: 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 09 09 20 . Exiting")....
2700: 20 20 28 65 78 69 74 29 29 29 0a 0a 20 20 20 20 (exit)))..
2710: 3b 3b 20 72 65 67 69 73 74 65 72 20 74 68 69 73 ;; register this
2720: 20 72 75 6e 20 69 6e 20 6d 6f 6e 69 74 6f 72 2e run in monitor.
2730: 64 62 0a 20 20 20 20 28 74 61 73 6b 73 3a 61 64 db. (tasks:ad
2740: 64 20 74 61 73 6b 73 2d 64 62 20 22 72 75 6e 2d d tasks-db "run-
2750: 74 65 73 74 73 22 20 75 73 65 72 20 74 61 72 67 tests" user targ
2760: 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d et runname test-
2770: 70 61 74 74 73 20 74 61 73 6b 2d 6b 65 79 29 20 patts task-key)
2780: 3b 3b 20 70 61 72 61 6d 73 29 0a 20 20 20 20 28 ;; params). (
2790: 74 61 73 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d tasks:set-state-
27a0: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
27b0: 74 61 73 6b 73 2d 64 62 20 74 61 73 6b 2d 6b 65 tasks-db task-ke
27c0: 79 20 22 72 75 6e 6e 69 6e 67 22 29 0a 20 20 20 y "running").
27d0: 20 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 (runs:set-megat
27e0: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e est-env-vars run
27f0: 2d 69 64 20 69 6e 6b 65 79 73 3a 20 6b 65 79 73 -id inkeys: keys
2800: 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e inrunname: runn
2810: 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 ame) ;; these ma
2820: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
2830: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
2840: 63 65 73 73 0a 20 20 20 20 28 69 66 20 28 66 69 cess. (if (fi
2850: 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f le-exists? runco
2860: 6e 66 69 67 66 29 0a 09 28 73 65 74 75 70 2d 65 nfigf)..(setup-e
2870: 6e 76 2d 64 65 66 61 75 6c 74 73 20 72 75 6e 63 nv-defaults runc
2880: 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 onfigf run-id *a
2890: 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 lready-seen-runc
28a0: 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 6b 65 79 76 onfig-info* keyv
28b0: 61 6c 73 20 74 61 72 67 65 74 29 0a 09 28 64 65 als target)..(de
28c0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
28d0: 4e 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 NING: You do not
28e0: 20 68 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 have a run conf
28f0: 69 67 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f ig file: " runco
2900: 6e 66 69 67 66 29 29 0a 0a 20 20 20 20 3b 3b 20 nfigf)).. ;;
2910: 4e 6f 77 20 67 65 6e 65 72 61 74 65 20 61 6c 6c Now generate all
2920: 20 74 68 65 20 74 65 73 74 73 20 6c 69 73 74 73 the tests lists
2930: 0a 20 20 20 20 28 73 65 74 21 20 61 6c 6c 2d 74 . (set! all-t
2940: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 28 74 ests-registry (t
2950: 65 73 74 73 3a 67 65 74 2d 61 6c 6c 29 29 0a 20 ests:get-all)).
2960: 20 20 20 28 73 65 74 21 20 61 6c 6c 2d 74 65 73 (set! all-tes
2970: 74 2d 6e 61 6d 65 73 20 20 20 20 20 28 68 61 73 t-names (has
2980: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 61 6c 6c h-table-keys all
2990: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 -tests-registry)
29a0: 29 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 ). (set! test
29b0: 2d 6e 61 6d 65 73 20 20 20 20 20 20 20 20 20 28 -names (
29c0: 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 tests:filter-tes
29d0: 74 2d 6e 61 6d 65 73 20 61 6c 6c 2d 74 65 73 74 t-names all-test
29e0: 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 -names test-patt
29f0: 73 29 29 0a 20 20 20 20 28 73 65 74 21 20 72 65 s)). (set! re
2a00: 71 75 69 72 65 64 2d 74 65 73 74 73 20 20 20 20 quired-tests
2a10: 20 28 6c 73 65 74 2d 69 6e 74 65 72 73 65 63 74 (lset-intersect
2a20: 69 6f 6e 20 65 71 75 61 6c 3f 20 28 73 74 72 69 ion equal? (stri
2a30: 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 ng-split test-pa
2a40: 74 74 73 20 22 2c 22 29 20 74 65 73 74 2d 6e 61 tts ",") test-na
2a50: 6d 65 73 29 29 0a 20 20 20 20 0a 20 20 20 20 3b mes)). . ;
2a60: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 ; look up all te
2a70: 73 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 sts matching the
2a80: 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 comma separated
2a90: 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 list of globs i
2aa0: 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 n. ;; test-pa
2ab0: 74 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 tts (using % as
2ac0: 77 69 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 3b wildcard).. ;
2ad0: 3b 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d ; (set! test-nam
2ae0: 65 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 es (delete-dupli
2af0: 63 61 74 65 73 20 28 74 65 73 74 73 3a 67 65 74 cates (tests:get
2b00: 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 2a 74 6f -valid-tests *to
2b10: 70 70 61 74 68 2a 20 74 65 73 74 2d 70 61 74 74 ppath* test-patt
2b20: 73 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a s))). (debug:
2b30: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 print-info 0 "te
2b40: 73 74 73 20 73 65 61 72 63 68 20 70 61 74 68 3a sts search path:
2b50: 20 22 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 " (tests:get-te
2b60: 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 sts-search-path
2b70: 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a 20 20 *configdat*)).
2b80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
2b90: 6e 66 6f 20 30 20 22 61 6c 6c 20 74 65 73 74 73 nfo 0 "all tests
2ba0: 3a 20 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 : " (string-int
2bb0: 65 72 73 70 65 72 73 65 20 28 73 6f 72 74 20 61 ersperse (sort a
2bc0: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 20 73 74 ll-test-names st
2bd0: 72 69 6e 67 3c 29 20 22 20 22 29 29 0a 20 20 20 ring<) " ")).
2be0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2bf0: 66 6f 20 30 20 22 74 65 73 74 20 6e 61 6d 65 73 fo 0 "test names
2c00: 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 : " (string-inte
2c10: 72 73 70 65 72 73 65 20 28 73 6f 72 74 20 74 65 rsperse (sort te
2c20: 73 74 2d 6e 61 6d 65 73 20 73 74 72 69 6e 67 3c st-names string<
2c30: 29 20 22 20 22 29 29 0a 0a 20 20 20 20 3b 3b 20 ) " ")).. ;;
2c40: 6f 6e 20 74 68 65 20 66 69 72 73 74 20 70 61 73 on the first pas
2c50: 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e s or call to run
2c60: 2d 74 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 -tests set FAILS
2c70: 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 to NOT_STARTED
2c80: 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 if. ;; -keepg
2c90: 6f 69 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 oing is specifie
2ca0: 64 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a d. (if (eq? *
2cb0: 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 passnum* 0)..(be
2cc0: 67 69 6e 0a 09 20 20 3b 3b 20 49 73 20 74 68 69 gin.. ;; Is thi
2cd0: 73 20 73 74 69 6c 6c 20 6e 65 63 65 73 73 61 72 s still necessar
2ce0: 79 3f 20 49 20 74 68 69 6e 6b 20 6e 6f 74 2e 20 y? I think not.
2cf0: 55 6e 72 65 61 63 68 61 62 6c 65 20 74 65 73 74 Unreachable test
2d00: 73 20 61 72 65 20 6d 61 72 6b 65 64 20 61 73 20 s are marked as
2d10: 73 75 63 68 20 61 6e 64 20 0a 09 20 20 3b 3b 20 such and .. ;;
2d20: 73 68 6f 75 6c 64 20 6e 6f 74 20 63 61 75 73 65 should not cause
2d30: 20 70 72 6f 62 6c 65 6d 73 20 68 65 72 65 2e 0a problems here..
2d40: 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 68 61 76 65 . ;;.. ;; have
2d50: 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 20 to delete test
2d60: 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e 4f records where NO
2d70: 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 20 T_STARTED since
2d80: 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 2d they can cause -
2d90: 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 20 keepgoing to ..
2da0: 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 75 ;; get stuck du
2db0: 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 6e e to becoming in
2dc0: 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d 20 accessible from
2dd0: 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 49 a failed test. I
2de0: 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 65 .e. if test B de
2df0: 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 pends .. ;; on
2e00: 74 65 73 74 20 41 20 62 75 74 20 74 65 73 74 20 test A but test
2e10: 42 20 72 65 61 63 68 65 64 20 74 68 65 20 70 6f B reached the po
2e20: 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 67 int on being reg
2e30: 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f 53 istered as NOT_S
2e40: 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 0a TARTED and test.
2e50: 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 66 . ;; A failed f
2e60: 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 74 or some reason t
2e70: 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 73 hen on re-run us
2e80: 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 ing -keepgoing t
2e90: 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 72 he run can never
2ea0: 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 3b 3b complete... ;;
2eb0: 0a 09 20 20 3b 3b 20 28 72 6d 74 3a 67 65 6e 65 .. ;; (rmt:gene
2ec0: 72 61 6c 2d 63 61 6c 6c 20 27 64 65 6c 65 74 65 ral-call 'delete
2ed0: 2d 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 -tests-in-state
2ee0: 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 run-id "NOT_STAR
2ef0: 54 45 44 22 29 0a 09 20 20 0a 09 20 20 3b 3b 20 TED").. .. ;;
2f00: 4e 6f 77 20 63 6f 6e 76 65 72 74 20 46 41 49 4c Now convert FAIL
2f10: 20 61 6e 64 20 61 6e 79 74 68 69 6e 67 20 69 6e and anything in
2f20: 20 61 6c 6c 6f 77 2d 61 75 74 6f 2d 72 65 72 75 allow-auto-reru
2f30: 6e 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 n to NOT_STARTED
2f40: 0a 09 20 20 3b 3b 0a 09 20 20 28 66 6f 72 2d 65 .. ;;.. (for-e
2f50: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 74 61 ach (lambda (sta
2f60: 74 65 29 0a 09 09 20 20 20 20 20 20 28 72 6d 74 te)... (rmt
2f70: 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 :set-tests-state
2f80: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 -status run-id t
2f90: 65 73 74 2d 6e 61 6d 65 73 20 73 74 61 74 65 20 est-names state
2fa0: 23 66 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 #f "NOT_STARTED"
2fb0: 20 73 74 61 74 65 29 29 0a 09 09 20 20 20 20 28 state))... (
2fc0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 6f 72 string-split (or
2fd0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
2fe0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
2ff0: 74 75 70 22 20 22 61 6c 6c 6f 77 2d 61 75 74 6f tup" "allow-auto
3000: 2d 72 65 72 75 6e 22 29 20 22 22 29 29 29 29 29 -rerun") "")))))
3010: 0a 0a 20 20 20 20 3b 3b 20 45 6e 73 75 72 65 20 .. ;; Ensure
3020: 61 6c 6c 20 74 65 73 74 73 20 61 72 65 20 72 65 all tests are re
3030: 67 69 73 74 65 72 65 64 20 69 6e 20 74 68 65 20 gistered in the
3040: 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 0a test_meta table.
3050: 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 65 (runs:update
3060: 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 23 -all-test_meta #
3070: 66 29 0a 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 f).. ;; now a
3080: 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 dd non-directly
3090: 72 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e referenced depen
30a0: 64 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 dencies (i.e. wa
30b0: 69 74 6f 6e 29 0a 20 20 20 20 3b 3b 3d 3d 3d 3d iton). ;;====
30c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3100: 3d 3d 0a 20 20 20 20 3b 3b 20 72 65 66 61 63 74 ==. ;; refact
3110: 6f 72 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b oring this block
3120: 20 69 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d into tests:get-
3130: 66 75 6c 6c 2d 64 61 74 61 0a 20 20 20 20 3b 3b full-data. ;;
3140: 0a 20 20 20 20 3b 3b 20 57 68 61 74 20 68 61 70 . ;; What hap
3150: 70 65 6e 64 65 64 2c 20 74 68 69 73 20 63 6f 64 pended, this cod
3160: 65 20 69 73 20 6e 6f 77 20 64 75 70 6c 69 63 61 e is now duplica
3170: 74 65 64 20 69 6e 20 74 65 73 74 73 21 3f 0a 20 ted in tests!?.
3180: 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 3d 3d 3d 3d ;;. ;;====
3190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31d0: 3d 3d 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ==. (if (not
31e0: 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 (null? test-name
31f0: 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 s))..(let loop (
3200: 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e (hed (car test-n
3210: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c ames))... (tal
3220: 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 (cdr test-names
3230: 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 ))) ;; '
3240: 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c return-procs tel
3250: 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 ls the config re
3260: 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e ader to prep run
3270: 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 ning system but
3280: 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 return a proc..
3290: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
32a0: 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b ry *toppath*) ;;
32b0: 20 50 4c 45 41 53 45 20 4f 50 54 49 4d 49 5a 45 PLEASE OPTIMIZE
32c0: 20 4d 45 21 21 21 20 49 20 74 68 69 6e 6b 20 74 ME!!! I think t
32d0: 68 69 73 20 73 68 6f 75 6c 64 20 62 65 20 61 20 his should be a
32e0: 6e 6f 2d 6f 70 20 62 75 74 20 74 68 65 72 65 20 no-op but there
32f0: 61 72 65 20 73 65 76 65 72 61 6c 20 70 6c 61 63 are several plac
3300: 65 73 20 77 68 65 72 65 20 63 68 61 6e 67 65 2d es where change-
3310: 64 69 72 65 63 74 6f 72 69 65 73 20 63 6f 75 6c directories coul
3320: 64 20 62 65 20 68 61 70 70 65 6e 69 6e 67 2e 0a d be happening..
3330: 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 . (setenv "MT_T
3340: 45 53 54 5f 4e 41 4d 45 22 20 68 65 64 29 20 3b EST_NAME" hed) ;
3350: 3b 20 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f ; .. (let* ((co
3360: 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 nfig (tests:get
3370: 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 -testconfig hed
3380: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
3390: 72 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ry 'return-procs
33a0: 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 ))... (waitons (
33b0: 6c 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 let ((instr (if
33c0: 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 20 20 config ......
33d0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
33e0: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
33f0: 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 nts" "waiton")..
3400: 09 09 09 09 20 20 20 28 62 65 67 69 6e 20 3b 3b .... (begin ;;
3410: 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 No config means
3420: 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 this is a non-e
3430: 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 xistant test....
3440: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
3450: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f int 0 "ERROR: no
3460: 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 n-existent requi
3470: 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 red test \"" hed
3480: 20 22 5c 22 22 29 0a 09 09 09 09 09 20 20 20 20 "\"")......
3490: 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 09 (exit 1)))))...
34a0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
34b0: 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e t-info 8 "waiton
34c0: 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e s string is " in
34d0: 73 74 72 29 0a 09 09 09 20 20 20 20 28 6c 65 74 str).... (let
34e0: 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 0a 09 09 ((newwaitons...
34f0: 09 09 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c .. (string-spl
3500: 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 20 it (cond.......
3510: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e ((procedure? in
3520: 73 74 72 29 0a 09 09 09 09 09 09 20 20 20 28 6c str)....... (l
3530: 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 et ((res (instr)
3540: 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 ))....... (d
3550: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3560: 38 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 8 "waiton proced
3570: 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 ure results in s
3580: 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f tring " res " fo
3590: 72 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 r test " hed)...
35a0: 09 09 09 09 20 20 20 20 20 72 65 73 29 29 0a 09 .... res))..
35b0: 09 09 09 09 09 20 20 28 28 73 74 72 69 6e 67 3f ..... ((string?
35c0: 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 instr) inst
35d0: 72 29 0a 09 09 09 09 09 09 20 20 28 65 6c 73 65 r)....... (else
35e0: 20 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 4e 4f ....... ;; NO
35f0: 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 TE: This is actu
3600: 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 ally the case of
3610: 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b *no* waitons! ;
3620: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
3630: 20 22 45 52 52 4f 52 3a 20 73 6f 6d 65 74 68 69 "ERROR: somethi
3640: 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e ng went wrong in
3650: 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 processing wait
3660: 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 ons for test " h
3670: 65 64 29 0a 09 09 09 09 09 09 20 20 20 22 22 29 ed)....... "")
3680: 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 66 )))).... (f
3690: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
36a0: 29 0a 09 09 09 09 09 28 69 66 20 28 68 61 73 68 )......(if (hash
36b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
36c0: 6c 74 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 lt all-tests-reg
36d0: 69 73 74 72 79 20 78 20 23 66 29 0a 09 09 09 09 istry x #f).....
36e0: 09 20 20 20 20 23 74 0a 09 09 09 09 09 20 20 20 . #t......
36f0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 (begin......
3700: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3710: 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 0 "ERROR: test "
3720: 20 68 65 64 20 22 20 68 61 73 20 75 6e 72 65 63 hed " has unrec
3730: 6f 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 ognised waiton t
3740: 65 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 estname " x)....
3750: 09 09 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 .. #f)))...
3760: 09 09 20 20 20 20 20 20 6e 65 77 77 61 69 74 6f .. newwaito
3770: 6e 73 29 29 29 29 29 0a 09 20 20 20 20 28 64 65 ns))))).. (de
3780: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
3790: 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 "waitons: " wai
37a0: 74 6f 6e 73 29 0a 09 20 20 20 20 3b 3b 20 63 68 tons).. ;; ch
37b0: 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 eck for hed in w
37c0: 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 aitons => this w
37d0: 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 ould be circular
37e0: 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 , remove it and
37f0: 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b issue an.. ;;
3800: 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 error.. (if
3810: 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 74 (member hed wait
3820: 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 ons)...(begin...
3830: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3840: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 "ERROR: test "
3850: 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 64 hed " has listed
3860: 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 itself as a wai
3870: 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 ton, please corr
3880: 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 ect this!")...
3890: 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 66 (set! waitons (f
38a0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
38b0: 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 )(not (equal? x
38c0: 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 hed))) waitons))
38d0: 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b 3b )).. .. ;;
38e0: 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d 73 (items (items
38f0: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
3900: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 29 config config)))
3910: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
3920: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3930: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f efault test-reco
3940: 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 28 rds hed #f))...(
3950: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
3960: 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 test-records....
3970: 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 . hed (vector he
3980: 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 d ;; 0......
3990: 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 config ;;
39a0: 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 74 1...... wait
39b0: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 ons ;; 2......
39c0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
39d0: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
39e0: 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 ements" "priorit
39f0: 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 y") ;; prior
3a00: 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 20 ity 3......
3a10: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
3a20: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
3a30: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
3a40: 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b "items" #f)) ;;
3a50: 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 items 4.......
3a60: 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 (itemstable (h
3a70: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3a80: 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
3a90: 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 emstable" #f)))
3aa0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
3ab0: 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 if either items
3ac0: 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 or items table i
3ad0: 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 s a proc return
3ae0: 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 it so test runni
3af0: 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ng...... ;
3b00: 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e ; process can kn
3b10: 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 ow to call items
3b20: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
3b30: 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 20 config......
3b40: 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 ;; if either
3b50: 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f is a list and no
3b60: 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 ne is a proc go
3b70: 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 ahead and call g
3b80: 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 20 et-items......
3b90: 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 ;; otherwis
3ba0: 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 e return #f - th
3bb0: 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 is is not an ite
3bc0: 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 rated test......
3bd0: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 (cond....
3be0: 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
3bf0: 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 items) ....
3c00: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
3c10: 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 69 -info 4 "items i
3c20: 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
3c30: 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
3c40: 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 20 ....... items)
3c50: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c ;; cal
3c60: 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 c later.......((
3c70: 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 procedure? items
3c80: 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 64 table)....... (d
3c90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3ca0: 34 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 73 4 "itemstable is
3cb0: 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 a procedure, wi
3cc0: 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a ll calc later").
3cd0: 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 6c ...... itemstabl
3ce0: 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 e) ;; calc
3cf0: 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 66 later.......((f
3d00: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
3d10: 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 74 )........ (let
3d20: 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 ((val (car x)))
3d30: 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 ........ (if
3d40: 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c (procedure? val
3d50: 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 ) val #f))).....
3d60: 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 20 ... (append (if
3d70: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
3d80: 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 ems '())........
3d90: 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 . (if (list? ite
3da0: 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 mstable) itemsta
3db0: 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 ble '())))......
3dc0: 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 . 'have-procedur
3dd0: 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 6c e).......((or (l
3de0: 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 ist? items)(list
3df0: 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b ? itemstable)) ;
3e00: 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 ; calc now......
3e10: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
3e20: 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e 64 nfo 4 "items and
3e30: 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 itemstable are
3e40: 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c lists, calc now\
3e50: 6e 22 0a 09 09 09 09 09 09 09 09 20 20 20 22 20 n"......... "
3e60: 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d items: " item
3e70: 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 s " itemstable:
3e80: 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 " itemstable)...
3e90: 09 09 09 09 20 28 69 74 65 6d 73 3a 67 65 74 2d .... (items:get-
3ea0: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
3eb0: 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 g config))......
3ec0: 09 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 .(else #f)))
3ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ee0: 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 ;; not it
3ef0: 65 72 61 74 65 64 0a 09 09 09 09 09 20 20 20 20 erated......
3f00: 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d #f ;; item
3f10: 73 64 61 74 20 35 0a 09 09 09 09 09 20 20 20 20 sdat 5......
3f20: 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 #f ;; spar
3f30: 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 e - used for ite
3f40: 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 m-path......
3f50: 20 29 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 ))).. (for-e
3f60: 61 63 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 ach .. (lamb
3f70: 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 da (waiton)..
3f80: 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 (if (and wai
3f90: 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ton (not (member
3fa0: 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
3fb0: 65 73 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 es)))... (begi
3fc0: 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 72 n... (set! r
3fd0: 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 equired-tests (c
3fe0: 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 ons waiton requi
3ff0: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 red-tests))...
4000: 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 (set! test-na
4010: 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e mes (cons waiton
4020: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 test-names)))))
4030: 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e ;; was an appen
4040: 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 d, now a cons..
4050: 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 waitons)..
4060: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 (let ((remtest
4070: 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 s (delete-duplic
4080: 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 ates (append wai
4090: 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 tons tal))))..
40a0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
40b0: 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 ll? remtests))..
40c0: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 . (loop (car re
40d0: 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 mtests)(cdr remt
40e0: 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 ests)))))))..
40f0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
4100: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
4110: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d )..(debug:print-
4120: 69 6e 66 6f 20 31 20 22 41 64 64 69 6e 67 20 22 info 1 "Adding "
4130: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
4140: 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 " to the run que
4150: 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 ue")). ;; NOT
4160: 45 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c E: these are all
4170: 20 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 parent tests, i
4180: 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 tems are not exp
4190: 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 anded yet.. (
41a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
41b0: 20 34 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 4 "test-records
41c0: 3d 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e =" (hash-table->
41d0: 61 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 alist test-recor
41e0: 64 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 ds)). (let ((
41f0: 72 65 67 6c 65 6e 20 28 63 6f 6e 66 69 67 66 3a reglen (configf:
4200: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
4210: 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e 71 t* "setup" "runq
4220: 75 65 75 65 22 29 29 29 0a 20 20 20 20 20 20 28 ueue"))). (
4230: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 68 if (> (length (h
4240: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
4250: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 20 30 29 est-records)) 0)
4260: 0a 09 20 20 28 6c 65 74 2a 20 28 28 6b 65 65 70 .. (let* ((keep
4270: 2d 67 6f 69 6e 67 20 23 74 29 0a 09 09 20 28 74 -going #t)... (t
4280: 68 31 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d h1 (make-
4290: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
42a0: 29 0a 09 09 09 09 09 20 20 20 20 28 72 75 6e 73 )...... (runs
42b0: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
42c0: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
42d0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 test-records key
42e0: 76 61 6c 73 20 66 6c 61 67 73 20 74 65 73 74 2d vals flags test-
42f0: 70 61 74 74 73 20 72 65 71 75 69 72 65 64 2d 74 patts required-t
4300: 65 73 74 73 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 ests (any->numbe
4310: 72 20 72 65 67 6c 65 6e 29 20 61 6c 6c 2d 74 65 r reglen) all-te
4320: 73 74 73 2d 72 65 67 69 73 74 72 79 29 29 0a 09 sts-registry))..
4330: 09 09 09 09 20 20 22 72 75 6e 73 3a 72 75 6e 2d .... "runs:run-
4340: 74 65 73 74 73 2d 71 75 65 75 65 22 29 29 0a 09 tests-queue"))..
4350: 09 20 28 74 68 32 20 20 20 20 20 20 20 20 28 6d . (th2 (m
4360: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
4370: 64 61 20 28 29 09 09 09 09 20 20 20 20 0a 09 09 da ().... ...
4380: 09 09 09 20 20 20 20 3b 3b 20 28 72 6d 74 3a 66 ... ;; (rmt:f
4390: 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 ind-and-mark-inc
43a0: 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 omplete-all-runs
43b0: 29 29 29 29 29 20 43 41 4e 27 54 20 49 4e 54 45 ))))) CAN'T INTE
43c0: 52 52 55 50 54 20 49 54 20 2e 2e 2e 0a 09 09 09 RRUPT IT .......
43d0: 09 09 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e .. (let ((run
43e0: 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 61 6c -ids (rmt:get-al
43f0: 6c 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 09 l-run-ids)))....
4400: 09 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 .. (for-eac
4410: 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 h (lambda (run-i
4420: 64 29 0a 09 09 09 09 09 09 09 20 20 28 69 66 20 d)........ (if
4430: 6b 65 65 70 2d 67 6f 69 6e 67 0a 09 09 09 09 09 keep-going......
4440: 09 09 20 20 20 20 20 20 28 72 6d 74 3a 66 69 6e .. (rmt:fin
4450: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
4460: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 23 66 29 plete run-id #f)
4470: 29 29 20 3b 3b 20 6f 76 72 2d 64 65 61 64 74 69 )) ;; ovr-deadti
4480: 6d 65 29 29 29 0a 09 09 09 09 09 09 09 72 75 6e me)))........run
4490: 2d 69 64 73 29 29 29 0a 09 09 09 09 09 20 20 22 -ids)))...... "
44a0: 72 75 6e 73 3a 20 6d 61 72 6b 2d 69 6e 63 6f 6d runs: mark-incom
44b0: 70 6c 65 74 65 73 22 29 29 29 0a 09 20 20 20 20 pletes")))..
44c0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
44d0: 68 31 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 h1).. (thread
44e0: 2d 73 74 61 72 74 21 20 74 68 32 29 0a 09 20 20 -start! th2)..
44f0: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
4500: 74 68 31 29 0a 09 20 20 20 20 28 73 65 74 21 20 th1).. (set!
4510: 6b 65 65 70 2d 67 6f 69 6e 67 20 23 66 29 0a 09 keep-going #f)..
4520: 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e (thread-join
4530: 21 20 74 68 32 29 0a 09 20 20 20 20 3b 3b 20 69 ! th2).. ;; i
4540: 66 20 72 75 6e 2d 63 6f 75 6e 74 20 3e 20 30 20 f run-count > 0
4550: 63 61 6c 6c 2c 20 73 65 74 20 2d 70 72 65 63 6c call, set -precl
4560: 65 61 6e 20 61 6e 64 20 2d 72 65 72 75 6e 20 53 ean and -rerun S
4570: 54 55 43 4b 2f 44 45 41 44 0a 09 20 20 20 20 28 TUCK/DEAD.. (
4580: 69 66 20 28 3e 20 72 75 6e 2d 63 6f 75 6e 74 20 if (> run-count
4590: 30 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 0)...(begin...
45a0: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
45b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
45c0: 20 66 6c 61 67 73 20 22 2d 70 72 65 63 6c 65 61 flags "-preclea
45d0: 6e 22 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 n" #f))...
45e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
45f0: 20 66 6c 61 67 73 20 22 2d 70 72 65 63 6c 65 61 flags "-preclea
4600: 6e 22 20 23 74 29 29 0a 09 09 20 20 28 69 66 20 n" #t))... (if
4610: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
4620: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 -ref/default fla
4630: 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 gs "-rerun" #f))
4640: 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 ... (hash-t
4650: 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 20 able-set! flags
4660: 22 2d 72 65 72 75 6e 22 20 22 53 54 55 43 4b 2f "-rerun" "STUCK/
4670: 44 45 41 44 2c 6e 2f 61 2c 5a 45 52 4f 5f 49 54 DEAD,n/a,ZERO_IT
4680: 45 4d 53 22 29 29 0a 09 09 20 20 28 72 75 6e 73 EMS"))... (runs
4690: 3a 72 75 6e 2d 74 65 73 74 73 20 74 61 72 67 65 :run-tests targe
46a0: 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 70 t runname test-p
46b0: 61 74 74 73 20 75 73 65 72 20 66 6c 61 67 73 20 atts user flags
46c0: 72 75 6e 2d 63 6f 75 6e 74 3a 20 28 2d 20 72 75 run-count: (- ru
46d0: 6e 2d 63 6f 75 6e 74 20 31 29 29 29 29 29 0a 09 n-count 1)))))..
46e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
46f0: 6e 66 6f 20 30 20 22 4e 6f 20 74 65 73 74 73 20 nfo 0 "No tests
4700: 74 6f 20 72 75 6e 22 29 29 29 0a 20 20 20 20 28 to run"))). (
4710: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4720: 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 62 79 20 4 "All done by
4730: 68 65 72 65 22 29 0a 20 20 20 20 28 74 61 73 6b here"). (task
4740: 73 3a 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 s:set-state-give
4750: 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 74 61 73 6b n-param-key task
4760: 73 2d 64 62 20 74 61 73 6b 2d 6b 65 79 20 22 64 s-db task-key "d
4770: 6f 6e 65 22 29 0a 20 20 20 20 28 73 71 6c 69 74 one"). (sqlit
4780: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 74 61 73 e3:finalize! tas
4790: 6b 73 2d 64 62 29 29 29 0a 0a 0a 3b 3b 20 6c 6f ks-db)))...;; lo
47a0: 6f 70 20 6c 6f 67 69 63 2e 20 54 68 65 73 65 20 op logic. These
47b0: 61 72 65 20 75 73 65 64 20 69 6e 20 72 75 6e 73 are used in runs
47c0: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
47d0: 20 74 6f 20 6d 61 6b 65 20 69 74 20 61 20 62 69 to make it a bi
47e0: 74 20 6d 6f 72 65 20 72 65 61 64 61 62 6c 65 2e t more readable.
47f0: 0a 3b 3b 0a 3b 3b 20 49 66 20 72 65 67 20 6e 6f .;;.;; If reg no
4800: 74 20 66 75 6c 6c 20 61 6e 64 20 68 61 76 65 20 t full and have
4810: 69 74 65 6d 73 20 69 6e 20 74 61 6c 20 74 68 65 items in tal the
4820: 6e 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 72 n loop with (car
4830: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 tal)(cdr tal) r
4840: 65 67 20 72 65 72 75 6e 73 0a 3b 3b 20 49 66 20 eg reruns.;; If
4850: 72 65 67 20 69 73 20 66 75 6c 6c 20 28 69 2e 65 reg is full (i.e
4860: 2e 20 6c 65 6e 67 74 68 20 3e 3d 20 6e 0a 3b 3b . length >= n.;;
4870: 20 20 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 loop with (ca
4880: 72 20 72 65 67 29 20 74 61 6c 20 28 63 64 72 20 r reg) tal (cdr
4890: 72 65 67 29 20 72 65 72 75 6e 73 0a 3b 3b 20 49 reg) reruns.;; I
48a0: 66 20 74 61 6c 20 69 73 20 65 6d 70 74 79 0a 3b f tal is empty.;
48b0: 3b 20 20 20 62 75 74 20 68 61 76 65 20 69 74 65 ; but have ite
48c0: 6d 73 20 69 6e 20 72 65 67 3b 20 6c 6f 6f 70 20 ms in reg; loop
48d0: 77 69 74 68 20 28 63 61 72 20 72 65 67 29 28 63 with (car reg)(c
48e0: 64 72 20 72 65 67 29 20 27 28 29 20 72 65 72 75 dr reg) '() reru
48f0: 6e 73 0a 3b 3b 20 20 20 49 66 20 72 65 67 20 69 ns.;; If reg i
4900: 73 20 65 6d 70 74 79 20 3d 3e 20 61 6c 6c 20 64 s empty => all d
4910: 6f 6e 65 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 one..(define (ru
4920: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
4930: 64 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 d tal reg n regf
4940: 75 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 ull). (if regfu
4950: 6c 6c 0a 20 20 20 20 20 20 28 63 61 72 20 72 65 ll. (car re
4960: 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 g). (if (nu
4970: 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 74 61 6c 20 ll? tal) ;; tal
4980: 69 73 20 75 73 65 64 20 75 70 2c 20 70 6f 70 20 is used up, pop
4990: 66 72 6f 6d 20 72 65 67 0a 09 20 20 28 63 61 72 from reg.. (car
49a0: 20 72 65 67 29 0a 09 20 20 28 63 61 72 20 74 61 reg).. (car ta
49b0: 6c 29 29 29 29 0a 0a 3b 3b 20 20 20 28 63 6f 6e l))))..;; (con
49c0: 64 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 72 65 d.;; ((and re
49d0: 67 66 75 6c 6c 20 28 6e 75 6c 6c 3f 20 72 65 67 gfull (null? reg
49e0: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
49f0: 29 29 29 20 20 20 20 20 20 28 63 61 72 20 74 61 ))) (car ta
4a00: 6c 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 l)).;; ((and
4a10: 72 65 67 66 75 6c 6c 20 28 6e 6f 74 20 28 6e 75 regfull (not (nu
4a20: 6c 6c 3f 20 72 65 67 29 29 29 20 20 20 20 20 20 ll? reg)))
4a30: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 (car
4a40: 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e reg)).;; ((an
4a50: 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c 29 28 d (not regfull)(
4a60: 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 6f 74 20 28 null? tal)(not (
4a70: 6e 75 6c 6c 3f 20 72 65 67 29 29 29 20 28 63 61 null? reg))) (ca
4a80: 72 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 r reg)).;; ((
4a90: 61 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c and (not regfull
4aa0: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
4ab0: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 28 ))) (
4ac0: 63 61 72 20 74 61 6c 29 29 0a 3b 3b 20 20 20 20 car tal)).;;
4ad0: 28 65 6c 73 65 0a 3b 3b 20 20 20 20 20 28 64 65 (else.;; (de
4ae0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
4af0: 4f 52 3a 20 72 75 6e 73 3a 71 75 65 75 65 2d 6e OR: runs:queue-n
4b00: 65 78 74 2d 68 65 64 2c 20 74 61 6c 3d 22 20 74 ext-hed, tal=" t
4b10: 61 6c 20 22 2c 20 72 65 67 3d 22 20 72 65 67 20 al ", reg=" reg
4b20: 22 2c 20 6e 3d 22 20 6e 20 22 2c 20 72 65 67 66 ", n=" n ", regf
4b30: 75 6c 6c 3d 22 20 72 65 67 66 75 6c 6c 29 0a 3b ull=" regfull).;
4b40: 3b 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 ; #f)))..(de
4b50: 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 fine (runs:queue
4b60: 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 -next-tal tal re
4b70: 67 20 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 28 g n regfull). (
4b80: 69 66 20 72 65 67 66 75 6c 6c 0a 20 20 20 20 20 if regfull.
4b90: 20 74 61 6c 0a 20 20 20 20 20 20 28 69 66 20 28 tal. (if (
4ba0: 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 6d 75 null? tal) ;; mu
4bb0: 73 74 20 74 72 61 6e 73 66 65 72 20 66 72 6f 6d st transfer from
4bc0: 20 72 65 67 0a 09 20 20 28 63 64 72 20 72 65 67 reg.. (cdr reg
4bd0: 29 0a 09 20 20 28 63 64 72 20 74 61 6c 29 29 29 ).. (cdr tal)))
4be0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
4bf0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
4c00: 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c tal reg n regful
4c10: 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c 6c l). (if regfull
4c20: 0a 20 20 20 20 20 20 28 63 64 72 20 72 65 67 29 . (cdr reg)
4c30: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
4c40: 3f 20 74 61 6c 29 20 3b 3b 20 69 66 20 74 61 6c ? tal) ;; if tal
4c50: 20 69 73 20 6e 75 6c 6c 20 61 6e 64 20 72 65 67 is null and reg
4c60: 20 6e 6f 74 20 66 75 6c 6c 20 74 68 65 6e 20 27 not full then '
4c70: 28 29 20 61 73 20 72 65 67 20 63 6f 6e 74 65 6e () as reg conten
4c80: 74 73 20 6d 6f 76 65 64 20 74 6f 20 74 61 6c 0a ts moved to tal.
4c90: 09 20 20 27 28 29 0a 09 20 20 72 65 67 29 29 29 . '().. reg)))
4ca0: 0a 0a 28 64 65 66 69 6e 65 20 72 75 6e 73 3a 6e ..(define runs:n
4cb0: 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 othing-left-in-q
4cc0: 75 65 75 65 2d 63 6f 75 6e 74 20 30 29 0a 0a 28 ueue-count 0)..(
4cd0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 65 78 70 define (runs:exp
4ce0: 61 6e 64 2d 69 74 65 6d 73 20 68 65 64 20 74 61 and-items hed ta
4cf0: 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 67 l reg reruns reg
4d00: 66 75 6c 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 67 full newtal jobg
4d10: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
4d20: 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 ent-jobs run-id
4d30: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
4d40: 68 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d h testmode test-
4d50: 72 65 63 6f 72 64 20 63 61 6e 2d 72 75 6e 2d 6d record can-run-m
4d60: 6f 72 65 20 69 74 65 6d 73 20 72 75 6e 6e 61 6d ore items runnam
4d70: 65 20 74 63 6f 6e 66 69 67 20 72 65 67 6c 65 6e e tconfig reglen
4d80: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 test-registry t
4d90: 65 73 74 2d 72 65 63 6f 72 64 73 20 69 74 65 6d est-records item
4da0: 6d 61 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c map). (let* ((l
4db0: 6f 6f 70 2d 6c 69 73 74 20 20 20 20 20 20 20 28 oop-list (
4dc0: 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 list hed tal reg
4dd0: 20 72 65 72 75 6e 73 29 29 0a 09 20 28 70 72 65 reruns)).. (pre
4de0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 72 6d reqs-not-met (rm
4df0: 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f t:get-prereqs-no
4e00: 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 t-met run-id wai
4e10: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 tons item-path t
4e20: 65 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 70 3a estmode itemmap:
4e30: 20 69 74 65 6d 6d 61 70 29 29 0a 09 20 3b 3b 20 itemmap)).. ;;
4e40: 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 (prereqs-not-met
4e50: 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 72 (mt:lazy-get-pr
4e60: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru
4e70: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
4e80: 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 m-path mode: tes
4e90: 74 6d 6f 64 65 20 69 74 65 6d 6d 61 70 3a 20 69 tmode itemmap: i
4ea0: 74 65 6d 6d 61 70 29 29 0a 09 20 28 66 61 69 6c temmap)).. (fail
4eb0: 73 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e s (run
4ec0: 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 s:calc-fails pre
4ed0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 reqs-not-met))..
4ee0: 20 28 70 72 65 72 65 71 2d 66 61 69 6c 73 20 20 (prereq-fails
4ef0: 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 70 72 65 (runs:calc-pre
4f00: 72 65 71 2d 66 61 69 6c 20 70 72 65 72 65 71 73 req-fail prereqs
4f10: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 6e 6f -not-met)).. (no
4f20: 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 72 n-completed (r
4f30: 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d uns:calc-not-com
4f40: 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e pleted prereqs-n
4f50: 6f 74 2d 6d 65 74 29 29 0a 09 20 28 72 75 6e 6e ot-met)).. (runn
4f60: 61 62 6c 65 73 20 20 20 20 20 20 20 28 72 75 6e ables (run
4f70: 73 3a 63 61 6c 63 2d 72 75 6e 6e 61 62 6c 65 20 s:calc-runnable
4f80: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
4f90: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
4fa0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 53 54 41 52 int-info 4 "STAR
4fb0: 54 20 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 20 T OF INNER COND
4fc0: 23 32 20 22 0a 09 09 20 20 20 20 20 20 22 5c 6e #2 "... "\n
4fd0: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 can-run-more:
4fe0: 20 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 " can-run-more
4ff0: 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 74 65 73 ... "\n tes
5000: 74 6e 61 6d 65 3a 20 20 20 20 20 20 20 20 22 20 tname: "
5010: 68 65 64 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 hed... "\n
5020: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a prereqs-not-met:
5030: 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d " (runs:pretty-
5040: 73 74 72 69 6e 67 20 70 72 65 72 65 71 73 2d 6e string prereqs-n
5050: 6f 74 2d 6d 65 74 29 0a 09 09 20 20 20 20 20 20 ot-met)...
5060: 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 "\n non-complete
5070: 64 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 d: " (runs:pre
5080: 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 tty-string non-c
5090: 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 20 20 20 ompleted) ...
50a0: 20 20 20 22 5c 6e 20 70 72 65 72 65 71 2d 66 61 "\n prereq-fa
50b0: 69 6c 73 3a 20 20 20 20 22 20 28 72 75 6e 73 3a ils: " (runs:
50c0: 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 72 pretty-string pr
50d0: 65 72 65 71 2d 66 61 69 6c 73 29 0a 09 09 20 20 ereq-fails)...
50e0: 20 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 "\n fails:
50f0: 20 20 20 20 20 20 20 20 20 22 20 28 72 75 6e 73 " (runs
5100: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 66 :pretty-string f
5110: 61 69 6c 73 29 0a 09 09 20 20 20 20 20 20 22 5c ails)... "\
5120: 6e 20 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 n testmode:
5130: 20 20 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 " testmode...
5140: 20 20 20 20 20 20 22 5c 6e 20 28 6d 65 6d 62 65 "\n (membe
5150: 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 r 'toplevel test
5160: 6d 6f 64 65 29 3a 20 22 20 28 6d 65 6d 62 65 72 mode): " (member
5170: 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 'toplevel testm
5180: 6f 64 65 29 0a 09 09 20 20 20 20 20 20 22 5c 6e ode)... "\n
5190: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
51a0: 6c 65 74 65 64 29 3a 20 20 20 20 22 20 28 6e 75 leted): " (nu
51b0: 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 ll? non-complete
51c0: 64 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 72 d)... "\n r
51d0: 65 72 75 6e 73 3a 20 20 20 20 20 20 20 20 20 20 eruns:
51e0: 22 20 72 65 72 75 6e 73 0a 09 09 20 20 20 20 20 " reruns...
51f0: 20 22 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 "\n items:
5200: 20 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 " items...
5210: 20 20 20 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 "\n can-ru
5220: 6e 2d 6d 6f 72 65 3a 20 20 20 20 22 20 63 61 6e n-more: " can
5230: 2d 72 75 6e 2d 6d 6f 72 65 29 0a 0a 20 20 20 20 -run-more)..
5240: 28 63 6f 6e 64 0a 20 20 20 20 20 3b 3b 20 61 6c (cond. ;; al
5250: 6c 20 70 72 65 72 65 71 73 20 6d 65 74 2c 20 66 l prereqs met, f
5260: 69 72 65 20 6f 66 66 20 74 68 65 20 74 65 73 74 ire off the test
5270: 0a 20 20 20 20 20 3b 3b 20 6f 72 2c 20 69 66 20 . ;; or, if
5280: 69 74 20 69 73 20 61 20 27 74 6f 70 6c 65 76 65 it is a 'topleve
5290: 6c 20 74 65 73 74 20 61 6e 64 20 61 6c 6c 20 70 l test and all p
52a0: 72 65 72 65 71 73 20 6e 6f 74 20 6d 65 74 20 61 rereqs not met a
52b0: 72 65 20 43 4f 4d 50 4c 45 54 45 44 20 74 68 65 re COMPLETED the
52c0: 6e 20 6c 61 75 6e 63 68 0a 0a 20 20 20 20 20 28 n launch.. (
52d0: 28 61 6e 64 20 28 6e 6f 74 20 28 6d 65 6d 62 65 (and (not (membe
52e0: 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 r 'toplevel test
52f0: 6d 6f 64 65 29 29 0a 09 20 20 20 28 6d 65 6d 62 mode)).. (memb
5300: 65 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 er (hash-table-r
5310: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
5320: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m
5330: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
5340: 6d 65 20 68 65 64 20 69 74 65 6d 2d 70 61 74 68 me hed item-path
5350: 29 20 27 6e 2f 61 29 0a 09 09 20 20 20 27 28 44 ) 'n/a)... '(D
5360: 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f 76 65 64 20 ONOTRUN removed
5370: 43 41 4e 4e 4f 54 52 55 4e 29 29 29 20 3b 3b 20 CANNOTRUN))) ;;
5380: 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e *common:cant-run
5390: 2d 73 74 61 74 65 73 2d 73 79 6d 2a 29 20 3b 3b -states-sym*) ;;
53a0: 20 27 28 43 4f 4d 50 4c 45 54 45 44 20 4b 49 4c '(COMPLETED KIL
53b0: 4c 45 44 20 57 41 49 56 45 44 20 55 4e 4b 4e 4f LED WAIVED UNKNO
53c0: 57 4e 20 49 4e 43 4f 4d 50 4c 45 54 45 29 29 20 WN INCOMPLETE))
53d0: 3b 3b 20 74 72 79 20 74 6f 20 63 61 74 63 68 20 ;; try to catch
53e0: 72 65 70 65 61 74 20 70 72 6f 63 65 73 73 69 6e repeat processin
53f0: 67 20 6f 66 20 43 4f 4d 50 4c 45 54 45 44 20 74 g of COMPLETED t
5400: 65 73 74 73 20 68 65 72 65 0a 20 20 20 20 20 20 ests here.
5410: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5420: 6f 20 31 20 22 54 65 73 74 20 22 20 68 65 64 20 o 1 "Test " hed
5430: 22 20 73 65 74 20 74 6f 20 5c 22 22 20 28 68 61 " set to \"" (ha
5440: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
5450: 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 t-registry (runs
5460: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
5470: 6e 61 6d 65 20 68 65 64 20 69 74 65 6d 2d 70 61 name hed item-pa
5480: 74 68 29 29 20 22 5c 22 2e 20 52 65 6d 6f 76 69 th)) "\". Removi
5490: 6e 67 20 69 74 20 66 72 6f 6d 20 74 68 65 20 71 ng it from the q
54a0: 75 65 75 65 22 29 0a 20 20 20 20 20 20 28 69 66 ueue"). (if
54b0: 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (or (not (null?
54c0: 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 28 6e tal)).. (n
54d0: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 ot (null? reg)))
54e0: 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a .. (list (runs:
54f0: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 queue-next-hed t
5500: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
5510: 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 gfull)...(runs:q
5520: 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 ueue-next-tal ta
5530: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
5540: 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 full)...(runs:qu
5550: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
5560: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
5570: 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 0a 09 ull)...reruns)..
5580: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d
5590: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
55a0: 30 20 22 4e 6f 74 68 69 6e 67 20 6c 65 66 74 20 0 "Nothing left
55b0: 69 6e 20 74 68 65 20 71 75 65 75 65 21 22 29 0a in the queue!").
55c0: 09 20 20 20 20 3b 3b 20 49 66 20 67 65 74 20 68 . ;; If get h
55d0: 65 72 65 20 74 77 69 63 65 20 74 68 65 6e 20 77 ere twice then w
55e0: 65 20 6b 6e 6f 77 20 77 65 27 76 65 20 74 72 69 e know we've tri
55f0: 65 64 20 74 6f 20 65 78 70 61 6e 64 20 61 6c 6c ed to expand all
5600: 20 69 74 65 6d 73 0a 09 20 20 20 20 3b 3b 20 73 items.. ;; s
5610: 69 6e 63 65 20 74 68 65 72 65 20 6d 75 73 74 20 ince there must
5620: 62 65 20 61 20 6c 6f 67 69 63 20 69 73 73 75 65 be a logic issue
5630: 20 77 69 74 68 20 74 68 65 20 68 61 6e 64 6c 69 with the handli
5640: 6e 67 20 6f 66 20 6c 6f 6f 70 73 20 69 6e 20 74 ng of loops in t
5650: 68 65 20 0a 09 20 20 20 20 3b 3b 20 69 74 65 6d he .. ;; item
5660: 73 20 65 78 70 61 6e 64 20 70 68 61 73 65 20 77 s expand phase w
5670: 65 20 77 69 6c 6c 20 62 72 75 74 65 20 66 6f 72 e will brute for
5680: 63 65 20 61 6e 20 65 78 69 74 20 68 65 72 65 2e ce an exit here.
5690: 0a 09 20 20 20 20 28 69 66 20 28 3e 20 72 75 6e .. (if (> run
56a0: 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 s:nothing-left-i
56b0: 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 32 29 n-queue-count 2)
56c0: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
56d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
56e0: 52 4e 49 4e 47 3a 20 74 68 69 73 20 63 6f 6e 64 RNING: this cond
56f0: 69 74 69 6f 6e 20 69 73 20 74 72 69 67 67 65 72 ition is trigger
5700: 65 64 20 77 68 65 6e 20 74 68 65 72 65 20 77 65 ed when there we
5710: 72 65 20 6e 6f 20 69 74 65 6d 73 20 74 6f 20 65 re no items to e
5720: 78 70 61 6e 64 20 61 6e 64 20 6e 6f 74 68 69 6e xpand and nothin
5730: 67 20 74 6f 20 72 75 6e 2e 20 50 6c 65 61 73 65 g to run. Please
5740: 20 63 68 65 63 6b 20 79 6f 75 72 20 72 75 6e 20 check your run
5750: 66 6f 72 20 63 6f 6d 70 6c 65 74 65 6e 65 73 73 for completeness
5760: 22 29 0a 09 09 20 20 28 65 78 69 74 20 30 29 29 ")... (exit 0))
5770: 0a 09 09 28 73 65 74 21 20 72 75 6e 73 3a 6e 6f ...(set! runs:no
5780: 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 thing-left-in-qu
5790: 65 75 65 2d 63 6f 75 6e 74 20 28 2b 20 72 75 6e eue-count (+ run
57a0: 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 s:nothing-left-i
57b0: 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 31 29 n-queue-count 1)
57c0: 29 29 0a 09 20 20 20 20 23 66 29 29 29 0a 0a 20 )).. #f)))..
57d0: 20 20 20 20 3b 3b 20 0a 20 20 20 20 20 28 28 6f ;; . ((o
57e0: 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 r (null? prereqs
57f0: 2d 6e 6f 74 2d 6d 65 74 29 0a 09 20 20 28 61 6e -not-met).. (an
5800: 64 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 d (member 'tople
5810: 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 0a 09 20 vel testmode)..
5820: 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e (null? non
5830: 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a 20 20 -completed))).
5840: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5850: 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 65 78 -info 4 "runs:ex
5860: 70 61 6e 64 2d 69 74 65 6d 73 3a 20 28 6f 72 20 pand-items: (or
5870: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n
5880: 6f 74 2d 6d 65 74 29 20 28 61 6e 64 20 28 6d 65 ot-met) (and (me
5890: 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 mber 'toplevel t
58a0: 65 73 74 6d 6f 64 65 29 28 6e 75 6c 6c 3f 20 6e estmode)(null? n
58b0: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 22 on-completed)))"
58c0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 ). (let ((t
58d0: 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 74 73 3a est-name (tests:
58e0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
58f0: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
5900: 72 64 29 29 29 0a 09 28 73 65 74 65 6e 76 20 22 rd)))..(setenv "
5910: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
5920: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 28 73 st-name) ;; ..(s
5930: 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d etenv "MT_RUNNAM
5940: 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 28 E" runname)..(
5950: 72 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 73 runs:set-megates
5960: 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 t-env-vars run-i
5970: 64 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e d inrunname: run
5980: 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d name) ;; these m
5990: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
59a0: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
59b0: 6f 63 65 73 73 0a 09 28 6c 65 74 20 28 28 69 74 ocess..(let ((it
59c0: 65 6d 73 2d 6c 69 73 74 20 28 69 74 65 6d 73 3a ems-list (items:
59d0: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
59e0: 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 29 29 onfig tconfig)))
59f0: 0a 09 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 .. (if (list? i
5a00: 74 65 6d 73 2d 6c 69 73 74 29 0a 09 20 20 20 20 tems-list)..
5a10: 20 20 28 62 65 67 69 6e 0a 09 09 28 69 66 20 28 (begin...(if (
5a20: 6e 75 6c 6c 3f 20 69 74 65 6d 73 2d 6c 69 73 74 null? items-list
5a30: 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 )... (let ((t
5a40: 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d est-id (rmt:get-
5a50: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
5a60: 65 73 74 2d 6e 61 6d 65 20 22 22 29 29 29 0a 09 est-name "")))..
5a70: 09 20 20 20 20 20 20 28 6d 74 3a 74 65 73 74 2d . (mt:test-
5a80: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
5a90: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
5aa0: 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 st-id "NOT_START
5ab0: 45 44 22 20 22 5a 45 52 4f 5f 49 54 45 4d 53 22 ED" "ZERO_ITEMS"
5ac0: 20 22 46 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 "Failed to run
5ad0: 64 75 65 20 74 6f 20 66 61 69 6c 65 64 20 70 72 due to failed pr
5ae0: 65 72 65 71 75 69 73 69 74 65 73 22 29 29 29 0a erequisites"))).
5af0: 09 09 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 ..(tests:testque
5b00: 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 74 65 ue-set-items! te
5b10: 73 74 2d 72 65 63 6f 72 64 20 69 74 65 6d 73 2d st-record items-
5b20: 6c 69 73 74 29 0a 09 09 28 6c 69 73 74 20 68 65 list)...(list he
5b30: 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 d tal reg reruns
5b40: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
5b50: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
5b60: 30 20 22 45 52 52 4f 52 3a 20 54 68 65 20 70 72 0 "ERROR: The pr
5b70: 6f 63 20 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 oc from reading
5b80: 74 68 65 20 69 74 65 6d 73 20 74 61 62 6c 65 20 the items table
5b90: 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 did not yield a
5ba0: 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 65 list - please re
5bb0: 70 6f 72 74 20 74 68 69 73 22 29 0a 09 09 28 65 port this")...(e
5bc0: 78 69 74 20 31 29 29 29 29 29 29 0a 0a 20 20 20 xit 1))))))..
5bd0: 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 66 ((and (null? f
5be0: 61 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c 3f ails).. (null?
5bf0: 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 0a 09 prereq-fails)..
5c00: 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e (not (null? n
5c10: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a on-completed))).
5c20: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 6c (let* ((al
5c30: 6c 69 6e 71 75 65 75 65 20 28 6d 61 70 20 28 6c linqueue (map (l
5c40: 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 74 ambda (x)(if (st
5c50: 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a 74 ring? x) x (db:t
5c60: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
5c70: 20 78 29 29 29 0a 20 20 20 20 20 20 20 20 09 09 x))). ..
5c80: 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 6e 65 (append ne
5c90: 77 74 61 6c 20 72 65 72 75 6e 73 29 29 29 0a 09 wtal reruns)))..
5ca0: 20 20 20 20 20 3b 3b 20 70 72 65 72 65 71 73 74 ;; prereqst
5cb0: 72 73 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 rs is a list of
5cc0: 74 65 73 74 20 6e 61 6d 65 73 20 61 73 20 73 74 test names as st
5cd0: 72 69 6e 67 73 20 74 68 61 74 20 61 72 65 20 70 rings that are p
5ce0: 72 65 72 65 71 73 20 66 6f 72 20 68 65 64 0a 20 rereqs for hed.
5cf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 65 (pre
5d00: 72 65 71 73 74 72 73 20 28 64 65 6c 65 74 65 2d reqstrs (delete-
5d10: 64 75 70 6c 69 63 61 74 65 73 20 28 6d 61 70 20 duplicates (map
5d20: 28 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 (lambda (x)(if (
5d30: 73 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 string? x) x (db
5d40: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
5d50: 6d 65 20 78 29 29 29 0a 09 09 09 09 09 09 20 70 me x)))....... p
5d60: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
5d70: 29 0a 09 20 20 20 20 20 3b 3b 20 61 20 70 72 65 ).. ;; a pre
5d80: 72 65 71 20 74 68 61 74 20 69 73 20 6e 6f 74 20 req that is not
5d90: 66 6f 75 6e 64 20 69 6e 20 61 6c 6c 69 6e 71 75 found in allinqu
5da0: 65 75 65 20 77 69 6c 6c 20 62 65 20 70 75 74 20 eue will be put
5db0: 69 6e 20 74 68 65 20 6e 6f 74 69 6e 71 75 65 75 in the notinqueu
5dc0: 65 20 6c 69 73 74 0a 09 20 20 20 20 20 3b 3b 20 e list.. ;;
5dd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b . ;;
5de0: 20 28 6e 6f 74 69 6e 71 75 65 75 65 20 28 66 69 (notinqueue (fi
5df0: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
5e00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b . ;;
5e10: 20 20 20 20 09 09 20 20 20 28 6e 6f 74 20 28 6d .. (not (m
5e20: 65 6d 62 65 72 20 78 20 61 6c 6c 69 6e 71 75 65 ember x allinque
5e30: 75 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ue))).
5e40: 20 20 20 3b 3b 20 20 20 20 09 09 20 70 72 65 72 ;; .. prer
5e50: 65 71 73 74 72 73 29 29 0a 09 20 20 20 20 20 28 eqstrs)).. (
5e60: 67 69 76 65 2d 75 70 20 20 20 20 23 66 29 29 0a give-up #f)).
5e70: 0a 09 3b 3b 20 57 65 20 63 61 6e 20 67 65 74 20 ..;; We can get
5e80: 68 65 72 65 20 77 68 65 6e 20 61 20 70 72 65 72 here when a prer
5e90: 65 71 20 68 61 73 20 6e 6f 74 20 62 65 65 6e 20 eq has not been
5ea0: 72 75 6e 20 64 75 65 20 74 6f 20 2a 69 74 2a 20 run due to *it*
5eb0: 68 61 76 69 6e 67 20 61 20 70 72 65 72 65 71 20 having a prereq
5ec0: 74 68 61 74 20 66 61 69 6c 65 64 2e 0a 09 3b 3b that failed...;;
5ed0: 20 57 65 20 6e 65 65 64 20 74 6f 20 75 73 65 20 We need to use
5ee0: 74 68 69 73 20 74 6f 20 64 65 71 75 65 75 65 20 this to dequeue
5ef0: 74 68 69 73 20 69 74 65 6d 20 61 73 20 43 41 4e this item as CAN
5f00: 4e 4f 54 52 55 4e 0a 09 3b 3b 20 0a 09 28 69 66 NOTRUN..;; ..(if
5f10: 20 28 6d 65 6d 62 65 72 20 74 65 73 74 6d 6f 64 (member testmod
5f20: 65 20 27 28 74 6f 70 6c 65 76 65 6c 29 29 0a 09 e '(toplevel))..
5f30: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
5f40: 61 6d 62 64 61 20 28 70 72 65 72 65 71 29 0a 09 ambda (prereq)..
5f50: 09 09 28 69 66 20 28 65 71 3f 20 28 68 61 73 68 ..(if (eq? (hash
5f60: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5f70: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 lt test-registry
5f80: 20 70 72 65 72 65 71 20 27 6a 75 73 74 66 69 6e prereq 'justfin
5f90: 65 29 20 27 43 41 4e 4e 4f 54 52 55 4e 29 0a 09 e) 'CANNOTRUN)..
5fa0: 09 09 20 20 20 20 28 73 65 74 21 20 67 69 76 65 .. (set! give
5fb0: 2d 75 70 20 23 74 29 29 29 0a 09 09 20 20 20 20 -up #t)))...
5fc0: 20 20 70 72 65 72 65 71 73 74 72 73 29 29 0a 0a prereqstrs))..
5fd0: 09 28 69 66 20 28 61 6e 64 20 67 69 76 65 2d 75 .(if (and give-u
5fe0: 70 0a 09 09 20 28 6e 6f 74 20 28 61 6e 64 20 28 p... (not (and (
5ff0: 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 75 6c 6c 3f null? tal)(null?
6000: 20 72 65 67 29 29 29 29 0a 09 20 20 20 20 28 6c reg)))).. (l
6010: 65 74 20 28 28 74 72 69 6d 6d 65 64 2d 74 61 6c et ((trimmed-tal
6020: 20 28 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c 6f (mt:discard-blo
6030: 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d 69 cked-tests run-i
6040: 64 20 68 65 64 20 74 61 6c 20 74 65 73 74 2d 72 d hed tal test-r
6050: 65 63 6f 72 64 73 29 29 0a 09 09 20 20 28 74 72 ecords))... (tr
6060: 69 6d 6d 65 64 2d 72 65 67 20 28 6d 74 3a 64 69 immed-reg (mt:di
6070: 73 63 61 72 64 2d 62 6c 6f 63 6b 65 64 2d 74 65 scard-blocked-te
6080: 73 74 73 20 72 75 6e 2d 69 64 20 68 65 64 20 72 sts run-id hed r
6090: 65 67 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 eg test-records)
60a0: 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 )).. (debug
60b0: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e :print 1 "WARNIN
60c0: 47 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 G: test " hed "
60d0: 68 61 73 20 64 69 73 63 61 72 64 65 64 20 70 72 has discarded pr
60e0: 65 72 65 71 75 69 73 69 74 65 73 2c 20 72 65 6d erequisites, rem
60f0: 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 68 oving it from th
6100: 65 20 71 75 65 75 65 22 29 0a 0a 09 20 20 20 20 e queue")...
6110: 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 (let ((test-id
6120: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
6130: 64 20 72 75 6e 2d 69 64 20 68 65 64 20 22 22 29 d run-id hed "")
6140: 29 29 0a 09 09 28 6d 74 3a 74 65 73 74 2d 73 65 ))...(mt:test-se
6150: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
6160: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
6170: 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 -id "NOT_STARTED
6180: 22 20 22 50 52 45 51 5f 44 49 53 43 41 52 44 45 " "PREQ_DISCARDE
6190: 44 22 20 22 46 61 69 6c 65 64 20 74 6f 20 72 75 D" "Failed to ru
61a0: 6e 20 64 75 65 20 74 6f 20 64 69 73 63 61 72 64 n due to discard
61b0: 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 73 ed prerequisites
61c0: 22 29 29 0a 09 20 20 20 20 20 20 0a 09 20 20 20 ")).. ..
61d0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c (if (and (nul
61e0: 6c 3f 20 74 72 69 6d 6d 65 64 2d 74 61 6c 29 0a l? trimmed-tal).
61f0: 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 .. (null?
6200: 74 72 69 6d 6d 65 64 2d 72 65 67 29 29 0a 09 09 trimmed-reg))...
6210: 20 20 23 66 0a 09 09 20 20 28 6c 69 73 74 20 28 #f... (list (
6220: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
6230: 68 65 64 20 74 72 69 6d 6d 65 64 2d 74 61 6c 20 hed trimmed-tal
6240: 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 6c trimmed-reg regl
6250: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 en regfull)....(
6260: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
6270: 74 61 6c 20 74 72 69 6d 6d 65 64 2d 74 61 6c 20 tal trimmed-tal
6280: 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 6c trimmed-reg regl
6290: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 en regfull)....(
62a0: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
62b0: 72 65 67 20 74 72 69 6d 6d 65 64 2d 74 61 6c 20 reg trimmed-tal
62c0: 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 6c trimmed-reg regl
62d0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 72 en regfull)....r
62e0: 65 72 75 6e 73 29 29 29 0a 09 20 20 20 20 20 20 eruns)))..
62f0: 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 (list (car newta
6300: 6c 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e l)(append (cdr n
6310: 65 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 ewtal) reg) '()
6320: 72 65 72 75 6e 73 29 29 29 29 0a 0a 20 20 20 20 reruns))))..
6330: 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 66 61 ((and (null? fa
6340: 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c 3f 20 ils).. (null?
6350: 70 72 65 72 65 71 2d 66 61 69 6c 73 29 0a 09 20 prereq-fails)..
6360: 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d (null? non-com
6370: 70 6c 65 74 65 64 29 29 0a 20 20 20 20 20 20 28 pleted)). (
6380: 69 66 20 20 28 72 75 6e 73 3a 63 61 6e 2d 6b 65 if (runs:can-ke
6390: 65 70 2d 72 75 6e 6e 69 6e 67 3f 20 68 65 64 20 ep-running? hed
63a0: 35 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 5).. (begin..
63b0: 20 20 28 72 75 6e 73 3a 69 6e 63 2d 63 61 6e 74 (runs:inc-cant
63c0: 2d 72 75 6e 2d 74 65 73 74 73 20 68 65 64 29 0a -run-tests hed).
63d0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
63e0: 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 66 61 69 t-info 1 "no fai
63f0: 6c 73 20 69 6e 20 70 72 65 72 65 71 75 69 73 69 ls in prerequisi
6400: 74 65 73 20 66 6f 72 20 22 20 68 65 64 20 22 20 tes for " hed "
6410: 62 75 74 20 61 6c 73 6f 20 6e 6f 6e 65 20 72 75 but also none ru
6420: 6e 6e 69 6e 67 2c 20 6b 65 65 70 69 6e 67 20 22 nning, keeping "
6430: 20 68 65 64 20 22 20 66 6f 72 20 6e 6f 77 2e 20 hed " for now.
6440: 54 72 79 20 63 6f 75 6e 74 3a 20 22 20 28 68 61 Try count: " (ha
6450: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
6460: 61 75 6c 74 20 2a 73 65 65 6e 2d 63 61 6e 74 2d ault *seen-cant-
6470: 72 75 6e 2d 74 65 73 74 73 2a 20 68 65 64 20 30 run-tests* hed 0
6480: 29 29 0a 09 20 20 20 20 3b 3b 20 6e 75 6d 2d 72 )).. ;; num-r
6490: 65 74 72 69 65 73 20 63 6f 64 65 20 77 61 73 20 etries code was
64a0: 68 65 72 65 0a 09 20 20 20 20 3b 3b 20 77 65 20 here.. ;; we
64b0: 75 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 use this opportu
64c0: 6e 69 74 79 20 74 6f 20 6d 6f 76 65 20 63 6f 6e nity to move con
64d0: 74 65 6e 74 73 20 6f 66 20 72 65 67 20 74 6f 20 tents of reg to
64e0: 74 61 6c 0a 09 20 20 20 20 28 6c 69 73 74 20 28 tal.. (list (
64f0: 63 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 car newtal)(appe
6500: 6e 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 nd (cdr newtal)
6510: 72 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 reg) '() reruns)
6520: 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 20 77 69 ) ;; an issue wi
6530: 74 68 20 70 72 65 72 65 71 73 20 6e 6f 74 20 79 th prereqs not y
6540: 65 74 20 6d 65 74 3f 0a 09 20 20 28 62 65 67 69 et met?.. (begi
6550: 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 n.. (debug:pr
6560: 69 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 66 int-info 1 "no f
6570: 61 69 6c 73 20 69 6e 20 70 72 65 72 65 71 75 69 ails in prerequi
6580: 73 69 74 65 73 20 66 6f 72 20 22 20 68 65 64 20 sites for " hed
6590: 22 20 62 75 74 20 6e 6f 74 68 69 6e 67 20 73 65 " but nothing se
65a0: 65 6e 20 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 en running in a
65b0: 77 68 69 6c 65 2c 20 64 72 6f 70 70 69 6e 67 20 while, dropping
65c0: 74 65 73 74 20 22 20 68 65 64 20 22 20 66 72 6f test " hed " fro
65d0: 6d 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 22 m the run queue"
65e0: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 65 ).. (let ((te
65f0: 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 st-id (rmt:get-t
6600: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 68 65 est-id run-id he
6610: 64 20 22 22 29 29 29 0a 09 20 20 20 20 20 20 28 d ""))).. (
6620: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
6630: 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 e-status-by-id r
6640: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e un-id test-id "N
6650: 4f 54 5f 53 54 41 52 54 45 44 22 20 22 54 49 4d OT_STARTED" "TIM
6660: 45 44 5f 4f 55 54 22 20 22 4e 6f 74 68 69 6e 67 ED_OUT" "Nothing
6670: 20 73 65 65 6e 20 72 75 6e 6e 69 6e 67 20 69 6e seen running in
6680: 20 61 20 77 68 69 6c 65 2e 22 29 29 0a 09 20 20 a while."))..
6690: 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 (list (runs:qu
66a0: 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c eue-next-hed tal
66b0: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
66c0: 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 ull)... (runs:q
66d0: 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 ueue-next-tal ta
66e0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
66f0: 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a full)... (runs:
6700: 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 queue-next-reg t
6710: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
6720: 67 66 75 6c 6c 29 0a 09 09 20 20 72 65 72 75 6e gfull)... rerun
6730: 73 29 29 29 29 0a 0a 20 20 20 20 20 28 28 61 6e s)))).. ((an
6740: 64 20 0a 20 20 20 20 20 20 20 28 6f 72 20 28 6e d . (or (n
6750: 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 ot (null? fails)
6760: 29 0a 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c ).. (not (null
6770: 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 29 ? prereq-fails))
6780: 29 0a 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ). (member
6790: 20 27 6e 6f 72 6d 61 6c 20 74 65 73 74 6d 6f 64 'normal testmod
67a0: 65 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 e)). (debug
67b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 74 :print-info 1 "t
67c0: 65 73 74 20 22 20 20 68 65 64 20 22 20 28 6d 6f est " hed " (mo
67d0: 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 29 de=" testmode ")
67e0: 20 68 61 73 20 66 61 69 6c 65 64 20 70 72 65 72 has failed prer
67f0: 65 71 75 69 73 69 74 65 28 73 29 3b 20 22 0a 09 equisite(s); "..
6800: 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 ..(string-inters
6810: 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 perse (map (lamb
6820: 64 61 20 28 74 29 28 63 6f 6e 63 20 28 64 62 3a da (t)(conc (db:
6830: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
6840: 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 e t) ":" (db:tes
6850: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 22 2f t-get-state t)"/
6860: 22 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 "(db:test-get-st
6870: 61 74 75 73 20 74 29 29 29 20 66 61 69 6c 73 29 atus t))) fails)
6880: 20 22 2c 20 22 29 0a 09 09 09 22 2c 20 72 65 6d ", ")....", rem
6890: 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f oving it from to
68a0: 2d 64 6f 20 6c 69 73 74 22 29 0a 20 20 20 20 20 -do list").
68b0: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 (let ((test-id
68c0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
68d0: 20 72 75 6e 2d 69 64 20 68 65 64 20 22 22 29 29 run-id hed ""))
68e0: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c )..(if (not (nul
68f0: 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 l? prereq-fails)
6900: 29 0a 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d ).. (mt:test-
6910: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
6920: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
6930: 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 st-id "NOT_START
6940: 45 44 22 20 22 50 52 45 51 5f 44 49 53 43 41 52 ED" "PREQ_DISCAR
6950: 44 45 44 22 20 22 46 61 69 6c 65 64 20 74 6f 20 DED" "Failed to
6960: 72 75 6e 20 64 75 65 20 74 6f 20 70 72 69 6f 72 run due to prior
6970: 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 69 failed prerequi
6980: 73 69 74 65 73 22 29 0a 09 20 20 20 20 28 6d 74 sites").. (mt
6990: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
69a0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
69b0: 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 -id test-id "NOT
69c0: 5f 53 54 41 52 54 45 44 22 20 22 50 52 45 51 5f _STARTED" "PREQ_
69d0: 46 41 49 4c 22 20 20 20 20 20 20 22 46 61 69 6c FAIL" "Fail
69e0: 65 64 20 74 6f 20 72 75 6e 20 64 75 65 20 74 6f ed to run due to
69f0: 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 69 failed prerequi
6a00: 73 69 74 65 73 22 29 29 29 0a 20 20 20 20 20 20 sites"))).
6a10: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 (if (or (not (nu
6a20: 6c 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e ll? reg))(not (n
6a30: 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 28 ull? tal))).. (
6a40: 62 65 67 69 6e 0a 09 20 20 20 20 28 68 61 73 68 begin.. (hash
6a50: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
6a60: 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 27 43 -registry hed 'C
6a70: 41 4e 4e 4f 54 52 55 4e 29 0a 09 20 20 20 20 28 ANNOTRUN).. (
6a80: 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 list (runs:queue
6a90: 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 -next-hed tal re
6aa0: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
6ab0: 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 )... (runs:queu
6ac0: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
6ad0: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6ae0: 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 l)... (runs:que
6af0: 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 ue-next-reg tal
6b00: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
6b10: 6c 6c 29 0a 09 09 20 20 28 63 6f 6e 73 20 68 65 ll)... (cons he
6b20: 64 20 72 65 72 75 6e 73 29 29 29 0a 09 20 20 23 d reruns))).. #
6b30: 66 29 29 20 3b 3b 20 23 66 20 66 6c 61 67 73 20 f)) ;; #f flags
6b40: 64 6f 20 6e 6f 74 20 6c 6f 6f 70 0a 0a 20 20 20 do not loop..
6b50: 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 ((and (not (nu
6b60: 6c 6c 3f 20 66 61 69 6c 73 29 29 28 6d 65 6d 62 ll? fails))(memb
6b70: 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 er 'toplevel tes
6b80: 74 6d 6f 64 65 29 29 0a 20 20 20 20 20 20 28 69 tmode)). (i
6b90: 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
6ba0: 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 6c ? reg))(not (nul
6bb0: 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 28 6c l? tal))).. (l
6bc0: 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 ist (car newtal)
6bd0: 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e 65 77 (append (cdr new
6be0: 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 72 65 tal) reg) '() re
6bf0: 72 75 6e 73 29 0a 09 20 20 23 66 29 29 20 0a 20 runs).. #f)) .
6c00: 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 75 6e 6e ((null? runn
6c10: 61 62 6c 65 73 29 20 23 66 29 20 3b 3b 20 69 66 ables) #f) ;; if
6c20: 20 77 65 20 67 65 74 20 68 65 72 65 20 61 6e 64 we get here and
6c30: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 69 non-completed i
6c40: 73 20 6e 75 6c 6c 20 74 68 65 20 69 74 27 73 20 s null the it's
6c50: 61 6c 6c 20 6f 76 65 72 2e 0a 20 20 20 20 20 28 all over.. (
6c60: 65 6c 73 65 0a 20 20 20 20 20 20 28 64 65 62 75 else. (debu
6c70: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
6c80: 4e 47 3a 20 46 41 49 4c 53 20 6f 72 20 69 6e 63 NG: FAILS or inc
6c90: 6f 6d 70 6c 65 74 65 20 74 65 73 74 73 20 6d 61 omplete tests ma
6ca0: 79 62 65 20 70 72 65 76 65 6e 74 69 6e 67 20 63 ybe preventing c
6cb0: 6f 6d 70 6c 65 74 69 6f 6e 20 6f 66 20 74 68 69 ompletion of thi
6cc0: 73 20 72 75 6e 2e 20 57 61 74 63 68 20 66 6f 72 s run. Watch for
6cd0: 20 69 73 73 75 65 73 20 77 69 74 68 20 74 65 73 issues with tes
6ce0: 74 20 22 20 68 65 64 20 22 2c 20 63 6f 6e 74 69 t " hed ", conti
6cf0: 6e 75 69 6e 67 20 66 6f 72 20 6e 6f 77 22 29 0a nuing for now").
6d00: 20 20 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 28 ;; (list (
6d10: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
6d20: 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c hed tal reg regl
6d30: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 20 20 en regfull).
6d40: 20 20 3b 3b 20 20 20 09 28 72 75 6e 73 3a 71 75 ;; .(runs:qu
6d50: 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c eue-next-tal tal
6d60: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
6d70: 75 6c 6c 29 0a 20 20 20 20 20 20 3b 3b 20 20 20 ull). ;;
6d80: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
6d90: 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 t-reg tal reg re
6da0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 glen regfull).
6db0: 20 20 20 20 3b 3b 20 20 20 09 72 65 72 75 6e 73 ;; .reruns
6dc0: 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 ). (list (c
6dd0: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
6de0: 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e ewtal) reg rerun
6df0: 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 s)))))..(define
6e00: 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 (runs:mixed-list
6e10: 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 -testname-and-te
6e20: 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 strec->list-of-s
6e30: 74 72 69 6e 67 73 20 69 6e 6c 73 74 29 0a 20 20 trings inlst).
6e40: 28 69 66 20 28 6e 75 6c 6c 3f 20 69 6e 6c 73 74 (if (null? inlst
6e50: 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 ). '().
6e60: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
6e70: 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 t).. (cond..
6e80: 20 20 20 20 20 20 28 28 76 65 63 74 6f 72 3f 20 ((vector?
6e90: 74 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 t).. (let
6ea0: 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a ((test-name (db:
6eb0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
6ec0: 65 20 74 29 29 0a 09 09 20 20 20 20 20 28 69 74 e t))... (it
6ed0: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
6ee0: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
6ef0: 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d ))... (test-
6f00: 73 74 61 74 65 20 28 64 62 3a 74 65 73 74 2d 67 state (db:test-g
6f10: 65 74 2d 73 74 61 74 65 20 74 29 29 0a 09 09 20 et-state t))...
6f20: 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 (test-status
6f30: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
6f40: 61 74 75 73 20 74 29 29 29 0a 09 09 20 28 63 6f atus t)))... (co
6f50: 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 nc test-name (if
6f60: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
6f70: 74 68 20 22 22 29 20 22 22 20 22 2f 22 29 20 69 th "") "" "/") i
6f80: 74 65 6d 2d 70 61 74 68 20 22 3a 22 20 74 65 73 tem-path ":" tes
6f90: 74 2d 73 74 61 74 65 20 22 2f 22 20 74 65 73 74 t-state "/" test
6fa0: 2d 73 74 61 74 75 73 29 29 29 0a 09 20 20 20 20 -status)))..
6fb0: 20 20 28 28 73 74 72 69 6e 67 3f 20 74 29 0a 09 ((string? t)..
6fc0: 20 20 20 20 20 20 20 74 29 0a 09 20 20 20 20 20 t)..
6fd0: 20 28 65 6c 73 65 20 0a 09 20 20 20 20 20 20 20 (else ..
6fe0: 28 63 6f 6e 63 20 74 29 29 29 29 0a 09 20 20 20 (conc t))))..
6ff0: 69 6e 6c 73 74 29 29 29 0a 0a 28 64 65 66 69 6e inlst)))..(defin
7000: 65 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 73 2d e (runs:process-
7010: 65 78 70 61 6e 64 65 64 2d 74 65 73 74 73 20 68 expanded-tests h
7020: 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e ed tal reg rerun
7030: 73 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c s reglen regfull
7040: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 72 75 6e test-record run
7050: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
7060: 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 6f 75 tem-path jobgrou
7070: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
7080: 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 -jobs run-id wai
7090: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 tons item-path t
70a0: 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 61 74 estmode test-pat
70b0: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test
70c0: 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 s test-registry
70d0: 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 20 66 registry-mutex f
70e0: 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 72 75 6e lags keyvals run
70f0: 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 6c 6c -info newtal all
7100: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
7110: 69 74 65 6d 6d 61 70 29 0a 20 20 28 6c 65 74 2a itemmap). (let*
7120: 20 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ((run-limits-in
7130: 66 6f 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 fo (runs
7140: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
7150: 73 74 73 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 sts run-id jobgr
7160: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
7170: 6e 74 2d 6a 6f 62 73 29 29 20 3b 3b 20 6c 6f 6f nt-jobs)) ;; loo
7180: 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 6a 6f k at the test jo
7190: 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a bgroup and tot j
71a0: 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 20 28 68 obs running.. (h
71b0: 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 20 20 ave-resources
71c0: 20 20 20 20 20 20 20 28 63 61 72 20 72 75 6e 2d (car run-
71d0: 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 29 0a 09 20 limits-info))..
71e0: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 (num-running
71f0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
7200: 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ef run-limits-in
7210: 66 6f 20 31 29 29 0a 09 20 28 6e 75 6d 2d 72 75 fo 1)).. (num-ru
7220: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
7230: 70 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d p (list-ref run-
7240: 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 29 29 20 limits-info 2))
7250: 0a 09 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 .. (max-concurre
7260: 6e 74 2d 6a 6f 62 73 20 20 20 20 20 28 6c 69 73 nt-jobs (lis
7270: 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 t-ref run-limits
7280: 2d 69 6e 66 6f 20 33 29 29 0a 09 20 28 6a 6f 62 -info 3)).. (job
7290: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 -group-limit
72a0: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 (list-ref r
72b0: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 34 un-limits-info 4
72c0: 29 29 0a 09 20 28 70 72 65 72 65 71 73 2d 6e 6f )).. (prereqs-no
72d0: 74 2d 6d 65 74 20 20 20 20 20 20 20 20 20 28 72 t-met (r
72e0: 6d 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e mt:get-prereqs-n
72f0: 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 ot-met run-id wa
7300: 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 itons item-path
7310: 74 65 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 70 testmode itemmap
7320: 3a 20 69 74 65 6d 6d 61 70 29 29 0a 09 20 3b 3b : itemmap)).. ;;
7330: 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 (prereqs-not-me
7340: 74 20 20 20 20 20 20 20 20 20 28 6d 74 3a 6c 61 t (mt:la
7350: 7a 79 2d 67 65 74 2d 70 72 65 72 65 71 73 2d 6e zy-get-prereqs-n
7360: 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 ot-met run-id wa
7370: 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 itons item-path
7380: 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 20 69 mode: testmode i
7390: 74 65 6d 6d 61 70 3a 20 69 74 65 6d 6d 61 70 29 temmap: itemmap)
73a0: 29 0a 09 20 28 66 61 69 6c 73 20 20 20 20 20 20 ).. (fails
73b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 (ru
73c0: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
73d0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
73e0: 09 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 . (non-completed
73f0: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
7400: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
7410: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
7420: 6d 65 74 29 29 0a 09 20 28 6c 6f 6f 70 2d 6c 69 met)).. (loop-li
7430: 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 st
7440: 20 28 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 (list hed tal r
7450: 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 3b 3b eg reruns)).. ;;
7460: 20 63 6f 6e 66 69 67 75 72 65 20 74 68 65 20 6c configure the l
7470: 6f 61 64 20 72 75 6e 6e 65 72 0a 09 20 28 6e 75 oad runner.. (nu
7480: 6d 63 70 75 73 20 20 20 20 20 20 20 20 20 20 20 mcpus
7490: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
74a0: 74 2d 6e 75 6d 2d 63 70 75 73 29 29 0a 09 20 28 t-num-cpus)).. (
74b0: 6d 61 78 6c 6f 61 64 20 20 20 20 20 20 20 20 20 maxload
74c0: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
74d0: 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e >number (or (con
74e0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
74f0: 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c figdat* "jobtool
7500: 73 22 20 22 6d 61 78 6c 6f 61 64 22 29 20 22 33 s" "maxload") "3
7510: 22 29 29 29 0a 09 20 28 77 61 69 74 64 65 6c 61 "))).. (waitdela
7520: 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 y
7530: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
7540: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
7550: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
7560: 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 77 61 69 74 "jobtools" "wait
7570: 64 65 6c 61 79 22 29 20 22 36 30 22 29 29 29 29 delay") "60"))))
7580: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
7590: 74 2d 69 6e 66 6f 20 34 20 22 68 61 76 65 2d 72 t-info 4 "have-r
75a0: 65 73 6f 75 72 63 65 73 3a 20 22 20 68 61 76 65 esources: " have
75b0: 2d 72 65 73 6f 75 72 63 65 73 20 22 20 70 72 65 -resources " pre
75c0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 28 22 reqs-not-met: ("
75d0: 20 0a 09 09 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
75e0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
75f0: 09 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 . (map (la
7600: 6d 62 64 61 20 28 74 29 0a 09 09 09 20 20 20 20 mbda (t)....
7610: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 74 (if (vector? t
7620: 29 0a 09 09 09 09 20 20 28 63 6f 6e 63 20 28 64 )..... (conc (d
7630: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
7640: 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 t) "/" (db:test
7650: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 0a -get-status t)).
7660: 09 09 09 09 20 20 28 63 6f 6e 63 20 22 20 57 41 .... (conc " WA
7670: 52 4e 49 4e 47 3a 20 74 20 69 73 20 6e 6f 74 20 RNING: t is not
7680: 61 20 76 65 63 74 6f 72 3d 22 20 74 20 29 29 29 a vector=" t )))
7690: 0a 09 09 09 20 20 20 20 70 72 65 72 65 71 73 2d .... prereqs-
76a0: 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 20 22 not-met) ", ") "
76b0: 29 20 66 61 69 6c 73 3a 20 22 20 66 61 69 6c 73 ) fails: " fails
76c0: 29 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 28 ). . (if (
76d0: 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 and (not (null?
76e0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
76f0: 29 0a 09 20 20 20 20 20 28 72 75 6e 73 3a 6c 6f ).. (runs:lo
7700: 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 77 61 wnoise (conc "wa
7710: 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 20 22 iting on tests "
7720: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
7730: 20 68 65 64 29 20 36 30 29 29 0a 09 28 64 65 62 hed) 60))..(deb
7740: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
7750: 22 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 "waiting on test
7760: 73 3b 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 s; " (string-int
7770: 65 72 73 70 65 72 73 65 20 28 72 75 6e 73 3a 6d ersperse (runs:m
7780: 69 78 65 64 2d 6c 69 73 74 2d 74 65 73 74 6e 61 ixed-list-testna
7790: 6d 65 2d 61 6e 64 2d 74 65 73 74 72 65 63 2d 3e me-and-testrec->
77a0: 6c 69 73 74 2d 6f 66 2d 73 74 72 69 6e 67 73 20 list-of-strings
77b0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
77c0: 20 22 2c 20 22 29 29 29 0a 0a 20 20 20 20 3b 3b ", "))).. ;;
77d0: 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 74 Don't know at t
77e0: 68 69 73 20 74 69 6d 65 20 69 66 20 74 68 65 20 his time if the
77f0: 74 65 73 74 20 68 61 76 65 20 62 65 65 6e 20 6c test have been l
7800: 61 75 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 20 aunched at some
7810: 74 69 6d 65 20 69 6e 20 74 68 65 20 70 61 73 74 time in the past
7820: 0a 20 20 20 20 3b 3b 20 69 2e 65 2e 20 69 73 20 . ;; i.e. is
7830: 74 68 69 73 20 61 20 72 65 2d 6c 61 75 6e 63 68 this a re-launch
7840: 3f 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ?. (debug:pri
7850: 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 2d 6c nt-info 4 "run-l
7860: 69 6d 69 74 73 2d 69 6e 66 6f 20 3d 20 22 20 72 imits-info = " r
7870: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 0a un-limits-info).
7880: 20 20 20 20 0a 20 20 20 20 28 63 6f 6e 64 0a 20 . (cond.
7890: 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 43 68 65 . ;; Che
78a0: 63 6b 20 69 74 65 6d 20 70 61 74 68 20 61 67 61 ck item path aga
78b0: 69 6e 73 74 20 69 74 65 6d 2d 70 61 74 74 73 2c inst item-patts,
78c0: 20 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 . ;;. (
78d0: 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 63 (not (tests:matc
78e0: 68 20 74 65 73 74 2d 70 61 74 74 73 20 28 74 65 h test-patts (te
78f0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
7900: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
7910: 72 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 record) item-pat
7920: 68 20 72 65 71 75 69 72 65 64 3a 20 72 65 71 75 h required: requ
7930: 69 72 65 64 2d 74 65 73 74 73 29 29 20 3b 3b 20 ired-tests)) ;;
7940: 54 68 69 73 20 74 65 73 74 2f 69 74 65 6d 70 61 This test/itempa
7950: 74 68 20 69 73 20 6e 6f 74 20 74 6f 20 62 65 20 th is not to be
7960: 72 75 6e 0a 20 20 20 20 20 20 3b 3b 20 65 6c 73 run. ;; els
7970: 65 20 74 68 65 20 72 75 6e 20 69 73 20 73 74 75 e the run is stu
7980: 63 6b 2c 20 74 65 6d 70 6f 72 61 72 69 6c 79 20 ck, temporarily
7990: 6f 72 20 70 65 72 6d 61 6e 65 6e 74 6c 79 0a 20 or permanently.
79a0: 20 20 20 20 20 3b 3b 20 62 75 74 20 73 68 6f 75 ;; but shou
79b0: 6c 64 20 63 68 65 63 6b 20 69 66 20 69 74 20 69 ld check if it i
79c0: 73 20 64 75 65 20 74 6f 20 6c 61 63 6b 20 6f 66 s due to lack of
79d0: 20 72 65 73 6f 75 72 63 65 73 20 76 73 2e 20 70 resources vs. p
79e0: 72 65 72 65 71 75 69 73 69 74 65 73 0a 20 20 20 rerequisites.
79f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
7a00: 69 6e 66 6f 20 31 20 22 53 6b 69 70 70 69 6e 67 info 1 "Skipping
7a10: 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 " (tests:testqu
7a20: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
7a30: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 20 test-record) "
7a40: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 73 " item-path " as
7a50: 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 63 it doesn't matc
7a60: 68 20 22 20 74 65 73 74 2d 70 61 74 74 73 29 0a h " test-patts).
7a70: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
7a80: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 ot (null? tal))(
7a90: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 not (null? reg))
7aa0: 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e 73 ).. (list (runs
7ab0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
7ac0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
7ad0: 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a egfull)...(runs:
7ae0: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
7af0: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
7b00: 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 gfull)...(runs:q
7b10: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 ueue-next-reg ta
7b20: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
7b30: 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 0a full)...reruns).
7b40: 09 20 20 23 66 29 29 0a 20 20 20 20 20 0a 20 20 . #f)). .
7b50: 20 20 20 3b 3b 20 52 65 67 69 73 74 65 72 20 74 ;; Register t
7b60: 65 73 74 73 20 0a 20 20 20 20 20 3b 3b 0a 20 20 ests . ;;.
7b70: 20 20 20 28 28 6e 6f 74 20 28 68 61 73 68 2d 74 ((not (hash-t
7b80: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7b90: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
7ba0: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
7bb0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
7bc0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 me item-path) #f
7bd0: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
7be0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 50 72 print-info 4 "Pr
7bf0: 65 2d 72 65 67 69 73 74 65 72 69 6e 67 20 74 65 e-registering te
7c00: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
7c10: 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 74 /" item-path " t
7c20: 6f 20 63 72 65 61 74 65 20 70 6c 61 63 65 68 6f o create placeho
7c30: 6c 64 65 72 22 20 29 0a 20 20 20 20 20 20 28 69 lder" ). (i
7c40: 66 20 23 74 20 3b 3b 20 61 6c 77 61 79 73 20 64 f #t ;; always d
7c50: 6f 20 66 69 72 6d 20 72 65 67 69 73 74 72 61 74 o firm registrat
7c60: 69 6f 6e 20 6e 6f 77 20 69 6e 20 76 31 2e 36 30 ion now in v1.60
7c70: 20 61 6e 64 20 67 72 65 61 74 65 72 20 3b 3b 20 and greater ;;
7c80: 28 65 71 3f 20 2a 74 72 61 6e 73 70 6f 72 74 2d (eq? *transport-
7c90: 74 79 70 65 2a 20 27 66 73 29 20 3b 3b 20 6e 6f type* 'fs) ;; no
7ca0: 20 70 6f 69 6e 74 20 69 6e 20 70 61 72 61 6c 6c point in parall
7cb0: 65 6c 20 72 65 67 69 73 74 72 61 74 69 6f 6e 20 el registration
7cc0: 69 66 20 75 73 65 20 66 73 0a 09 20 20 28 62 65 if use fs.. (be
7cd0: 67 69 6e 0a 09 20 20 20 20 28 72 6d 74 3a 67 65 gin.. (rmt:ge
7ce0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 neral-call 'regi
7cf0: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
7d00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
7d10: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 e item-path)..
7d20: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
7d30: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
7d40: 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c (runs:make-full
7d50: 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d -test-name test-
7d60: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 name item-path)
7d70: 27 64 6f 6e 65 29 29 0a 09 20 20 28 6c 65 74 20 'done)).. (let
7d80: 28 28 74 68 20 28 6d 61 6b 65 2d 74 68 72 65 61 ((th (make-threa
7d90: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ()....
7da0: 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 . (mutex-lock!
7db0: 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 29 registry-mutex)
7dc0: 0a 09 09 09 09 20 20 20 28 68 61 73 68 2d 74 61 ..... (hash-ta
7dd0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
7de0: 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b gistry (runs:mak
7df0: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
7e00: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
7e10: 70 61 74 68 29 20 27 73 74 61 72 74 29 0a 09 09 path) 'start)...
7e20: 09 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f .. (mutex-unlo
7e30: 63 6b 21 20 72 65 67 69 73 74 72 79 2d 6d 75 74 ck! registry-mut
7e40: 65 78 29 0a 09 09 09 09 20 20 20 3b 3b 20 49 66 ex)..... ;; If
7e50: 20 68 61 76 65 6e 27 74 20 64 6f 6e 65 20 69 74 haven't done it
7e60: 20 62 65 66 6f 72 65 20 72 65 67 69 73 74 65 72 before register
7e70: 20 61 20 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 a top level tes
7e80: 74 20 69 66 20 74 68 69 73 20 69 73 20 61 6e 20 t if this is an
7e90: 69 74 65 6d 69 7a 65 64 20 74 65 73 74 0a 09 09 itemized test...
7ea0: 09 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 .. (if (not (e
7eb0: 71 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 q? (hash-table-r
7ec0: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
7ed0: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m
7ee0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
7ef0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 me test-name "")
7f00: 20 23 66 29 20 27 64 6f 6e 65 29 29 0a 09 09 09 #f) 'done))....
7f10: 09 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e . (rmt:gen
7f20: 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 73 eral-call 'regis
7f30: 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ter-test run-id
7f40: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
7f50: 20 22 22 29 29 0a 09 09 09 09 20 20 20 28 72 6d ""))..... (rm
7f60: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
7f70: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 75 register-test ru
7f80: 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 n-id run-id test
7f90: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
7fa0: 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 6c ..... (mutex-l
7fb0: 6f 63 6b 21 20 72 65 67 69 73 74 72 79 2d 6d 75 ock! registry-mu
7fc0: 74 65 78 29 0a 09 09 09 09 20 20 20 28 68 61 73 tex)..... (has
7fd0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
7fe0: 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 t-registry (runs
7ff0: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
8000: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
8010: 74 65 6d 2d 70 61 74 68 29 20 27 64 6f 6e 65 29 tem-path) 'done)
8020: 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 75 ..... (mutex-u
8030: 6e 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 79 2d nlock! registry-
8040: 6d 75 74 65 78 29 29 0a 09 09 09 09 20 28 63 6f mutex))..... (co
8050: 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 nc test-name "/"
8060: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 item-path))))..
8070: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
8080: 74 21 20 74 68 29 29 29 0a 20 20 20 20 20 20 28 t! th))). (
8090: 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d runs:shrink-can-
80a0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
80b0: 6f 75 6e 74 29 20 20 20 3b 3b 20 44 45 4c 41 59 ount) ;; DELAY
80c0: 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 TWEAKER (still
80d0: 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 20 20 28 needed?). (
80e0: 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 74 if (and (null? t
80f0: 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 29 29 0a al)(null? reg)).
8100: 09 20 20 28 6c 69 73 74 20 68 65 64 20 74 61 6c . (list hed tal
8110: 20 28 61 70 70 65 6e 64 20 72 65 67 20 28 6c 69 (append reg (li
8120: 73 74 20 68 65 64 29 29 20 72 65 72 75 6e 73 29 st hed)) reruns)
8130: 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a .. (list (runs:
8140: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 queue-next-hed t
8150: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
8160: 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 gfull)...(runs:q
8170: 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 ueue-next-tal ta
8180: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
8190: 66 75 6c 6c 29 0a 09 09 3b 3b 20 4e 42 2f 2f 20 full)...;; NB//
81a0: 48 65 72 65 20 77 65 20 61 72 65 20 62 75 69 6c Here we are buil
81b0: 64 69 6e 67 20 72 65 67 20 61 73 20 77 65 20 72 ding reg as we r
81c0: 65 67 69 73 74 65 72 20 74 65 73 74 73 0a 09 09 egister tests...
81d0: 3b 3b 20 69 66 20 72 65 67 66 75 6c 6c 20 77 65 ;; if regfull we
81e0: 20 6d 75 73 74 20 70 6f 70 20 74 68 65 20 66 72 must pop the fr
81f0: 6f 6e 74 20 69 74 65 6d 20 6f 66 66 20 72 65 67 ont item off reg
8200: 0a 09 09 28 69 66 20 72 65 67 66 75 6c 6c 0a 09 ...(if regfull..
8210: 09 20 20 20 20 28 61 70 70 65 6e 64 20 28 63 64 . (append (cd
8220: 72 20 72 65 67 29 20 28 6c 69 73 74 20 68 65 64 r reg) (list hed
8230: 29 29 0a 09 09 20 20 20 20 28 61 70 70 65 6e 64 ))... (append
8240: 20 72 65 67 20 28 6c 69 73 74 20 68 65 64 29 29 reg (list hed))
8250: 29 0a 09 09 72 65 72 75 6e 73 29 29 29 0a 20 20 )...reruns))).
8260: 20 20 20 0a 20 20 20 20 20 3b 3b 20 41 74 20 74 . ;; At t
8270: 68 69 73 20 70 6f 69 6e 74 20 68 65 64 20 74 65 his point hed te
8280: 73 74 20 72 65 67 69 73 74 72 61 74 69 6f 6e 20 st registration
8290: 6d 75 73 74 20 62 65 20 63 6f 6d 70 6c 65 74 65 must be complete
82a0: 64 2e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 d.. ;;.
82b0: 28 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c ((eq? (hash-tabl
82c0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
82d0: 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e st-registry (run
82e0: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
82f0: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
8300: 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 0a 09 item-path) #f)..
8310: 20 20 20 27 73 74 61 72 74 29 0a 20 20 20 20 20 'start).
8320: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8330: 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 6f 6e fo 0 "Waiting on
8340: 20 74 65 73 74 20 72 65 67 69 73 74 72 61 74 69 test registrati
8350: 6f 6e 28 73 29 3a 20 22 0a 09 09 09 28 73 74 72 on(s): "....(str
8360: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
8370: 0a 09 09 09 20 28 66 69 6c 74 65 72 20 28 6c 61 .... (filter (la
8380: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 20 20 mbda (x).....
8390: 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 (eq? (hash-table
83a0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
83b0: 74 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 29 t-registry x #f)
83c0: 20 27 73 74 61 72 74 29 29 0a 09 09 09 09 20 28 'start))..... (
83d0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
83e0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 29 29 0a test-registry)).
83f0: 09 09 09 20 22 2c 20 22 29 29 0a 20 20 20 20 20 ... ", ")).
8400: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
8410: 30 2e 31 29 0a 20 20 20 20 20 20 28 6c 69 73 74 0.1). (list
8420: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
8430: 75 6e 73 29 29 0a 20 20 20 20 20 0a 20 20 20 20 uns)). .
8440: 20 3b 3b 20 49 66 20 6e 6f 20 72 65 73 6f 75 72 ;; If no resour
8450: 63 65 73 20 61 72 65 20 61 76 61 69 6c 61 62 6c ces are availabl
8460: 65 20 6a 75 73 74 20 6b 69 6c 6c 20 74 69 6d 65 e just kill time
8470: 20 61 6e 64 20 6c 6f 6f 70 20 61 67 61 69 6e 0a and loop again.
8480: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 28 6e ;;. ((n
8490: 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 ot have-resource
84a0: 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 72 79 s) ;; simply try
84b0: 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 61 69 again after wai
84c0: 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a 20 20 ting a second.
84d0: 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f (if (runs:lo
84e0: 77 6e 6f 69 73 65 20 22 6e 6f 20 72 65 73 6f 75 wnoise "no resou
84f0: 72 63 65 73 22 20 36 30 29 0a 09 20 20 28 64 65 rces" 60).. (de
8500: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
8510: 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 73 20 74 "no resources t
8520: 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 73 2c o run new tests,
8530: 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 29 0a waiting ...")).
8540: 20 20 20 20 20 20 3b 3b 20 48 61 76 65 20 67 6f ;; Have go
8550: 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 6f 72 74 ne back and fort
8560: 68 20 6f 6e 20 74 68 69 73 20 62 75 74 20 64 62 h on this but db
8570: 20 73 74 61 72 76 61 74 69 6f 6e 20 69 73 20 61 starvation is a
8580: 6e 20 69 73 73 75 65 2e 0a 20 20 20 20 20 20 3b n issue.. ;
8590: 3b 20 77 61 69 74 20 6f 6e 65 20 73 65 63 6f 6e ; wait one secon
85a0: 64 20 62 65 66 6f 72 65 20 6c 6f 6f 6b 69 6e 67 d before looking
85b0: 20 61 67 61 69 6e 20 74 6f 20 72 75 6e 20 6a 6f again to run jo
85c0: 62 73 2e 0a 20 20 20 20 20 20 28 74 68 72 65 61 bs.. (threa
85d0: 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 20 20 20 d-sleep! 1).
85e0: 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 65 20 ;; could have
85f0: 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 65 72 done hed tal her
8600: 65 20 62 75 74 20 64 6f 69 6e 67 20 63 61 72 2f e but doing car/
8610: 63 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 74 6f cdr of newtal to
8620: 20 72 6f 74 61 74 65 20 74 65 73 74 73 0a 20 20 rotate tests.
8630: 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 20 6e (list (car n
8640: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
8650: 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a l) reg reruns)).
8660: 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 54 68 . ;; Th
8670: 69 73 20 69 73 20 74 68 65 20 66 69 6e 61 6c 20 is is the final
8680: 73 74 61 67 65 2c 20 65 76 65 72 79 74 68 69 6e stage, everythin
8690: 67 20 69 73 20 69 6e 20 70 6c 61 63 65 20 73 6f g is in place so
86a0: 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 74 launch the test
86b0: 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 28 . ;;. ((
86c0: 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 72 63 and have-resourc
86d0: 65 73 0a 09 20 20 20 28 6f 72 20 28 6e 75 6c 6c es.. (or (null
86e0: 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 ? prereqs-not-me
86f0: 74 29 0a 09 20 20 20 20 20 20 20 28 61 6e 64 20 t).. (and
8700: 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 (eq? testmode 't
8710: 6f 70 6c 65 76 65 6c 29 0a 09 09 20 20 20 20 28 oplevel)... (
8720: 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 null? non-comple
8730: 74 65 64 29 29 29 29 0a 20 20 20 20 20 20 3b 3b ted)))). ;;
8740: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c (hash-table-del
8750: 65 74 65 21 20 2a 6d 61 78 2d 74 72 69 65 73 2d ete! *max-tries-
8760: 68 61 73 68 2a 20 28 72 75 6e 73 3a 6d 61 6b 65 hash* (runs:make
8770: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name
8780: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
8790: 61 74 68 29 29 0a 20 20 20 20 20 20 3b 3b 20 77 ath)). ;; w
87a0: 65 20 61 72 65 20 67 6f 69 6e 67 20 74 6f 20 72 e are going to r
87b0: 65 73 65 74 20 61 6c 6c 20 74 68 65 20 63 6f 75 eset all the cou
87c0: 6e 74 65 72 73 20 66 6f 72 20 74 65 73 74 20 72 nters for test r
87d0: 65 74 72 69 65 73 20 62 79 20 73 65 74 74 69 6e etries by settin
87e0: 67 20 61 20 6e 65 77 20 68 61 73 68 20 74 61 62 g a new hash tab
87f0: 6c 65 0a 20 20 20 20 20 20 3b 3b 20 74 68 69 73 le. ;; this
8800: 20 6d 65 61 6e 73 20 74 68 65 79 20 77 69 6c 6c means they will
8810: 20 69 6e 63 72 65 6d 65 6e 74 20 6f 6e 6c 79 20 increment only
8820: 77 68 65 6e 20 6e 6f 74 68 69 6e 67 20 63 61 6e when nothing can
8830: 20 62 65 20 72 75 6e 0a 20 20 20 20 20 20 28 73 be run. (s
8840: 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 et! *max-tries-h
8850: 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d ash* (make-hash-
8860: 74 61 62 6c 65 29 29 0a 20 20 20 20 20 20 3b 3b table)). ;;
8870: 20 77 65 6c 6c 2c 20 66 69 72 73 74 20 6c 65 74 well, first let
8880: 73 20 73 65 65 20 69 66 20 63 70 75 20 6c 6f 61 s see if cpu loa
8890: 64 20 74 68 72 6f 74 74 6c 69 6e 67 20 69 73 20 d throttling is
88a0: 65 6e 61 62 6c 65 64 2e 20 49 66 20 73 6f 20 77 enabled. If so w
88b0: 61 69 74 20 61 72 6f 75 6e 64 20 75 6e 74 69 6c ait around until
88c0: 20 74 68 65 0a 20 20 20 20 20 20 3b 3b 20 61 76 the. ;; av
88d0: 65 72 61 67 65 20 63 70 75 20 6c 6f 61 64 20 69 erage cpu load i
88e0: 73 20 75 6e 64 65 72 20 74 68 65 20 74 68 72 65 s under the thre
88f0: 73 68 6f 6c 64 20 62 65 66 6f 72 65 20 63 6f 6e shold before con
8900: 74 69 6e 75 69 6e 67 0a 20 20 20 20 20 20 28 69 tinuing. (i
8910: 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 f (configf:looku
8920: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
8930: 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 6c 6f 61 obtools" "maxloa
8940: 64 22 29 20 3b 3b 20 6f 6e 6c 79 20 67 61 74 65 d") ;; only gate
8950: 20 69 66 20 6d 61 78 6c 6f 61 64 20 69 73 20 73 if maxload is s
8960: 70 65 63 69 66 69 65 64 0a 09 20 20 28 63 6f 6d pecified.. (com
8970: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 mon:wait-for-cpu
8980: 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d load maxload num
8990: 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 29 29 cpus waitdelay))
89a0: 0a 20 20 20 20 20 20 28 72 75 6e 3a 74 65 73 74 . (run:test
89b0: 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f run-id run-info
89c0: 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 keyvals runname
89d0: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 test-record fla
89e0: 67 73 20 23 66 20 74 65 73 74 2d 72 65 67 69 73 gs #f test-regis
89f0: 74 72 79 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 try all-tests-re
8a00: 67 69 73 74 72 79 29 0a 20 20 20 20 20 20 28 68 gistry). (h
8a10: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
8a20: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 est-registry (ru
8a30: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
8a40: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name
8a50: 20 69 74 65 6d 2d 70 61 74 68 29 20 27 72 75 6e item-path) 'run
8a60: 6e 69 6e 67 29 0a 20 20 20 20 20 20 28 72 75 6e ning). (run
8a70: 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e s:shrink-can-run
8a80: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
8a90: 74 29 20 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 t) ;; DELAY TWE
8aa0: 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 AKER (still need
8ab0: 65 64 3f 29 0a 20 20 20 20 20 20 3b 3b 20 28 74 ed?). ;; (t
8ac0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c hread-sleep! *gl
8ad0: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 20 20 20 obal-delta*).
8ae0: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
8af0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 (null? tal))(not
8b00: 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 0a 09 (null? reg)))..
8b10: 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 (list (runs:qu
8b20: 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c eue-next-hed tal
8b30: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
8b40: 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 ull)...(runs:que
8b50: 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 ue-next-tal tal
8b60: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
8b70: 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 ll)...(runs:queu
8b80: 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 e-next-reg tal r
8b90: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
8ba0: 6c 29 0a 09 09 72 65 72 75 6e 73 29 0a 09 20 20 l)...reruns)..
8bb0: 23 66 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 #f)). .
8bc0: 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 ;; must be we ha
8bd0: 76 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 ve unmet prerequ
8be0: 69 73 69 74 65 73 0a 20 20 20 20 20 3b 3b 0a 20 isites. ;;.
8bf0: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
8c00: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
8c10: 46 41 49 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a FAILS: " fails).
8c20: 20 20 20 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 ;; If one
8c30: 6f 72 20 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 or more of the p
8c40: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 rereqs-not-met a
8c50: 72 65 20 46 41 49 4c 20 74 68 65 6e 20 77 65 20 re FAIL then we
8c60: 63 61 6e 20 69 73 73 75 65 0a 20 20 20 20 20 20 can issue.
8c70: 3b 3b 20 61 20 6d 65 73 73 61 67 65 20 61 6e 64 ;; a message and
8c80: 20 64 72 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 drop hed from t
8c90: 68 65 20 69 74 65 6d 73 20 74 6f 20 62 65 20 70 he items to be p
8ca0: 72 6f 63 65 73 73 65 64 2e 0a 20 20 20 20 20 20 rocessed..
8cb0: 3b 3b 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c ;; (runs:mixed-l
8cc0: 69 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 ist-testname-and
8cd0: 2d 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f -testrec->list-o
8ce0: 66 2d 73 74 72 69 6e 67 73 20 70 72 65 72 65 71 f-strings prereq
8cf0: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 20 20 20 s-not-met).
8d00: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
8d10: 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f null? prereqs-no
8d20: 74 2d 6d 65 74 29 29 0a 09 20 20 20 20 20 20 20 t-met))..
8d30: 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 (runs:lownoise (
8d40: 63 6f 6e 63 20 22 77 61 69 74 69 6e 67 20 6f 6e conc "waiting on
8d50: 20 74 65 73 74 73 20 22 20 70 72 65 72 65 71 73 tests " prereqs
8d60: 2d 6e 6f 74 2d 6d 65 74 20 68 65 64 29 20 36 30 -not-met hed) 60
8d70: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
8d80: 6e 74 2d 69 6e 66 6f 20 31 20 22 77 61 69 74 69 nt-info 1 "waiti
8d90: 6e 67 20 6f 6e 20 74 65 73 74 73 3b 20 22 20 28 ng on tests; " (
8da0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
8db0: 73 65 20 0a 09 09 09 09 09 09 20 20 20 20 28 72 se ....... (r
8dc0: 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 2d 74 uns:mixed-list-t
8dd0: 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 73 74 estname-and-test
8de0: 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 rec->list-of-str
8df0: 69 6e 67 73 20 0a 09 09 09 09 09 09 20 20 20 20 ings .......
8e00: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
8e10: 29 20 22 2c 20 22 29 29 29 0a 20 20 20 20 20 20 ) ", "))).
8e20: 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 (if (null? fails
8e30: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
8e40: 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e ;; couldn't run
8e50: 2c 20 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 , take a breathe
8e60: 72 0a 09 20 20 20 20 28 69 66 20 20 28 72 75 6e r.. (if (run
8e70: 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 57 61 69 74 s:lownoise "Wait
8e80: 69 6e 67 20 66 6f 72 20 6d 6f 72 65 20 77 6f 72 ing for more wor
8e90: 6b 20 74 6f 20 64 6f 2e 2e 2e 22 20 36 30 29 0a k to do..." 60).
8ea0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
8eb0: 69 6e 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 info 0 "Waiting
8ec0: 66 6f 72 20 6d 6f 72 65 20 77 6f 72 6b 20 74 6f for more work to
8ed0: 20 64 6f 2e 2e 2e 22 29 29 0a 09 20 20 20 20 28 do...")).. (
8ee0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
8ef0: 0a 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 .. (list (car
8f00: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
8f10: 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 tal) reg reruns)
8f20: 29 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 ).. ;; the wait
8f30: 6f 6e 20 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f on is FAIL so no
8f40: 20 70 6f 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 point in trying
8f50: 20 74 6f 20 72 75 6e 20 68 65 64 20 65 76 65 72 to run hed ever
8f60: 20 61 67 61 69 6e 0a 09 20 20 28 69 66 20 28 6f again.. (if (o
8f70: 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 r (not (null? re
8f80: 67 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 g))(not (null? t
8f90: 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 al))).. (if
8fa0: 20 28 76 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 (vector? hed)..
8fb0: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
8fc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
8fd0: 57 41 52 4e 49 4e 47 3a 20 44 72 6f 70 70 69 6e WARNING: Droppin
8fe0: 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 g test " test-na
8ff0: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
9000: 0a 09 09 09 09 20 22 20 66 72 6f 6d 20 74 68 65 ..... " from the
9010: 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 launch list as
9020: 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 it has prerequis
9030: 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 tes that are FAI
9040: 4c 22 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 L")... (let (
9050: 28 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 (test-id (rmt:ge
9060: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
9070: 20 68 65 64 20 22 22 29 29 29 0a 09 09 20 20 20 hed "")))...
9080: 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d (mt:test-set-
9090: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
90a0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
90b0: 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 d "NOT_STARTED"
90c0: 22 50 52 45 51 5f 46 41 49 4c 22 20 22 46 61 69 "PREQ_FAIL" "Fai
90d0: 6c 65 64 20 74 6f 20 72 75 6e 20 64 75 65 20 74 led to run due t
90e0: 6f 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 o failed prerequ
90f0: 69 73 69 74 65 73 22 29 29 0a 09 09 20 20 20 20 isites"))...
9100: 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e (runs:shrink-can
9110: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
9120: 63 6f 75 6e 74 29 20 3b 3b 20 44 45 4c 41 59 20 count) ;; DELAY
9130: 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e TWEAKER (still n
9140: 65 65 64 65 64 3f 29 0a 09 09 20 20 20 20 3b 3b eeded?)... ;;
9150: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
9160: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a *global-delta*).
9170: 09 09 20 20 20 20 3b 3b 20 54 68 69 73 20 6e 65 .. ;; This ne
9180: 78 74 20 69 73 20 66 6f 72 20 74 68 65 20 69 74 xt is for the it
9190: 65 6d 73 0a 09 09 20 20 20 20 28 6d 74 3a 74 65 ems... (mt:te
91a0: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
91b0: 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d 65 20 tus-by-testname
91c0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
91d0: 20 69 74 65 6d 2d 70 61 74 68 20 22 4e 4f 54 5f item-path "NOT_
91e0: 53 54 41 52 54 45 44 22 20 22 42 4c 4f 43 4b 45 STARTED" "BLOCKE
91f0: 44 22 20 23 66 29 0a 09 09 20 20 20 20 28 68 61 D" #f)... (ha
9200: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
9210: 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e st-registry (run
9220: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
9230: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
9240: 69 74 65 6d 2d 70 61 74 68 29 20 27 72 65 6d 6f item-path) 'remo
9250: 76 65 64 29 0a 09 09 20 20 20 20 28 6c 69 73 74 ved)... (list
9260: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
9270: 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t-hed tal reg re
9280: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
9290: 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e . (runs:queue-n
92a0: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
92b0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
92c0: 09 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 ... (runs:queue
92d0: 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 -next-reg tal re
92e0: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
92f0: 29 0a 09 09 09 20 20 72 65 72 75 6e 73 20 3b 3b ).... reruns ;;
9300: 20 57 41 53 3a 20 28 63 6f 6e 73 20 68 65 64 20 WAS: (cons hed
9310: 72 65 72 75 6e 73 29 20 3b 3b 20 62 75 74 20 74 reruns) ;; but t
9320: 68 61 74 20 6d 61 6b 65 73 20 6e 6f 20 73 65 6e hat makes no sen
9330: 73 65 3f 0a 09 09 09 20 20 29 29 0a 09 09 20 20 se?.... ))...
9340: 28 6c 65 74 20 28 28 6e 74 68 2d 74 72 79 20 28 (let ((nth-try (
9350: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
9360: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 efault test-regi
9370: 73 74 72 79 20 68 65 64 20 30 29 29 29 0a 09 09 stry hed 0)))...
9380: 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
9390: 20 28 28 6d 65 6d 62 65 72 20 22 52 55 4e 4e 49 ((member "RUNNI
93a0: 4e 47 22 20 28 6d 61 70 20 64 62 3a 74 65 73 74 NG" (map db:test
93b0: 2d 67 65 74 2d 73 74 61 74 65 20 70 72 65 72 65 -get-state prere
93c0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 20 qs-not-met))...
93d0: 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c (if (runs:l
93e0: 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 70 ownoise (conc "p
93f0: 6f 73 73 69 62 6c 65 20 52 55 4e 4e 49 4e 47 20 ossible RUNNING
9400: 70 72 65 72 65 71 75 69 73 74 65 73 20 22 20 68 prerequistes " h
9410: 65 64 29 20 36 30 29 0a 09 09 09 20 20 28 64 65 ed) 60).... (de
9420: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
9430: 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 68 65 64 NING: test " hed
9440: 20 22 20 68 61 73 20 70 6f 73 73 69 62 6c 65 20 " has possible
9450: 52 55 4e 4e 49 4e 47 20 70 72 65 72 65 71 75 69 RUNNING prerequi
9460: 73 69 74 65 73 2c 20 64 6f 6e 27 74 20 67 69 76 sites, don't giv
9470: 65 20 75 70 20 6f 6e 20 69 74 20 79 65 74 2e 22 e up on it yet."
9480: 29 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 ))... (thre
9490: 61 64 2d 73 6c 65 65 70 21 20 34 29 0a 09 09 20 ad-sleep! 4)...
94a0: 20 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 (list (runs
94b0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
94c0: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
94d0: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
94e0: 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 (runs:queue-ne
94f0: 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 xt-tal newtal re
9500: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
9510: 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 3a 71 ).... (runs:q
9520: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 ueue-next-reg ne
9530: 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 wtal reg reglen
9540: 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 regfull)....
9550: 72 65 72 75 6e 73 29 29 0a 09 09 20 20 20 20 20 reruns))...
9560: 28 28 6f 72 20 28 6e 6f 74 20 6e 74 68 2d 74 72 ((or (not nth-tr
9570: 79 29 0a 09 09 09 20 20 28 61 6e 64 20 28 6e 75 y).... (and (nu
9580: 6d 62 65 72 3f 20 6e 74 68 2d 74 72 79 29 0a 09 mber? nth-try)..
9590: 09 09 20 20 20 20 20 20 20 28 3c 20 6e 74 68 2d .. (< nth-
95a0: 74 72 79 20 31 30 29 29 29 0a 09 09 20 20 20 20 try 10)))...
95b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
95c0: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
95d0: 20 68 65 64 20 28 69 66 20 28 6e 75 6d 62 65 72 hed (if (number
95e0: 3f 20 6e 74 68 2d 74 72 79 29 0a 09 09 09 09 09 ? nth-try)......
95f0: 09 09 20 20 20 20 20 28 2b 20 6e 74 68 2d 74 72 .. (+ nth-tr
9600: 79 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 20 y 1)........
9610: 20 30 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 0))... (if
9620: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
9630: 28 63 6f 6e 63 20 22 6e 6f 74 20 72 65 6d 6f 76 (conc "not remov
9640: 69 6e 67 20 74 65 73 74 20 22 20 68 65 64 29 20 ing test " hed)
9650: 36 30 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 60).... (debug:
9660: 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 print 1 "WARNING
9670: 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 74 : not removing t
9680: 65 73 74 20 22 20 68 65 64 20 22 20 66 72 6f 6d est " hed " from
9690: 20 71 75 65 75 65 20 61 6c 74 68 6f 75 67 68 20 queue although
96a0: 69 74 20 6d 61 79 20 6e 6f 74 20 62 65 20 72 75 it may not be ru
96b0: 6e 6e 61 62 6c 65 20 64 75 65 20 74 6f 20 46 41 nnable due to FA
96c0: 49 4c 45 44 20 70 72 65 72 65 71 75 69 73 69 74 ILED prerequisit
96d0: 65 73 22 29 29 0a 09 09 20 20 20 20 20 20 3b 3b es"))... ;;
96e0: 20 6d 61 79 20 6e 6f 74 20 68 61 76 65 20 70 72 may not have pr
96f0: 6f 63 65 73 73 65 64 20 63 6f 72 72 65 63 74 6c ocessed correctl
9700: 79 2e 20 43 6f 75 6c 64 20 62 65 20 61 20 72 61 y. Could be a ra
9710: 63 65 20 63 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 ce condition in
9720: 79 6f 75 72 20 74 65 73 74 20 69 6d 70 6c 65 6d your test implem
9730: 65 6e 74 61 74 69 6f 6e 3f 20 44 72 6f 70 70 69 entation? Droppi
9740: 6e 67 20 74 65 73 74 20 22 20 68 65 64 29 20 3b ng test " hed) ;
9750: 3b 20 20 22 20 61 73 20 69 74 20 68 61 73 20 70 ; " as it has p
9760: 72 65 72 65 71 75 69 73 74 65 73 20 74 68 61 74 rerequistes that
9770: 20 61 72 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 are FAIL. (NOTE
9780: 3a 20 68 65 64 20 69 73 20 6e 6f 74 20 61 20 76 : hed is not a v
9790: 65 63 74 6f 72 29 22 29 0a 09 09 20 20 20 20 20 ector)")...
97a0: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
97b0: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
97c0: 2d 63 6f 75 6e 74 29 20 3b 3b 20 44 45 4c 41 59 -count) ;; DELAY
97d0: 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 TWEAKER (still
97e0: 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 20 20 20 needed?)...
97f0: 20 3b 3b 20 28 6c 69 73 74 20 68 65 64 20 74 61 ;; (list hed ta
9800: 6c 20 72 65 67 20 72 65 72 75 6e 73 29 0a 09 09 l reg reruns)...
9810: 20 20 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 28 ;; (list (
9820: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
9830: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
9840: 6e 73 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 ns)... ;; (
9850: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9860: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 65 test-registry he
9870: 64 20 27 72 65 6d 6f 76 65 64 29 0a 09 09 20 20 d 'removed)...
9880: 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a (list (runs:
9890: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e queue-next-hed n
98a0: 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e ewtal reg reglen
98b0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 regfull)....
98c0: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
98d0: 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 t-tal newtal reg
98e0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
98f0: 0a 09 09 09 20 20 20 20 28 72 75 6e 73 3a 71 75 .... (runs:qu
9900: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 eue-next-reg new
9910: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
9920: 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 72 egfull).... r
9930: 65 72 75 6e 73 29 29 0a 09 09 20 20 20 20 20 28 eruns))... (
9940: 28 73 79 6d 62 6f 6c 3f 20 6e 74 68 2d 74 72 79 (symbol? nth-try
9950: 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 )... (if (e
9960: 71 3f 20 6e 74 68 2d 74 72 79 20 27 72 65 6d 6f q? nth-try 'remo
9970: 76 65 64 29 20 3b 3b 20 72 65 6d 6f 76 65 64 20 ved) ;; removed
9980: 69 73 20 72 65 6d 6f 76 65 64 20 2d 20 64 72 6f is removed - dro
9990: 70 20 69 74 20 4e 4f 57 0a 09 09 09 20 20 28 69 p it NOW.... (i
99a0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
99b0: 09 20 20 20 20 20 20 23 66 20 3b 3b 20 79 65 73 . #f ;; yes
99c0: 2c 20 72 65 61 6c 6c 79 0a 09 09 09 20 20 20 20 , really....
99d0: 20 20 28 6c 69 73 74 20 28 63 61 72 20 74 61 6c (list (car tal
99e0: 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 20 72 )(cdr tal) reg r
99f0: 65 72 75 6e 73 29 29 0a 09 09 09 20 20 28 62 65 eruns)).... (be
9a00: 67 69 6e 0a 09 09 09 20 20 20 20 28 69 66 20 28 gin.... (if (
9a10: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 runs:lownoise (c
9a20: 6f 6e 63 20 22 46 41 49 4c 45 44 20 70 72 65 72 onc "FAILED prer
9a30: 65 71 75 69 73 69 74 65 73 20 6f 72 20 6f 74 68 equisites or oth
9a40: 65 72 20 69 73 73 75 65 22 20 68 65 64 29 20 36 er issue" hed) 6
9a50: 30 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 0).....(debug:pr
9a60: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
9a70: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
9a80: 20 46 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 FAILED prerequi
9a90: 73 69 74 65 73 20 6f 72 20 6f 74 68 65 72 20 69 sites or other i
9aa0: 73 73 75 65 2e 20 49 6e 74 65 72 6e 61 6c 20 73 ssue. Internal s
9ab0: 74 61 74 65 20 22 20 6e 74 68 2d 74 72 79 20 22 tate " nth-try "
9ac0: 20 77 69 6c 6c 20 62 65 20 6f 76 65 72 72 69 64 will be overrid
9ad0: 64 65 6e 20 61 6e 64 20 77 65 27 6c 6c 20 72 65 den and we'll re
9ae0: 74 72 79 2e 22 29 29 0a 09 09 09 20 20 20 20 28 try.")).... (
9af0: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
9b00: 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 e-status-by-test
9b10: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
9b20: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
9b30: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 4b "NOT_STARTED" "K
9b40: 45 45 50 5f 54 52 59 49 4e 47 22 20 23 66 29 0a EEP_TRYING" #f).
9b50: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
9b60: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
9b70: 69 73 74 72 79 20 68 65 64 20 30 29 0a 09 09 09 istry hed 0)....
9b80: 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a (list (runs:
9b90: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e queue-next-hed n
9ba0: 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e ewtal reg reglen
9bb0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 09 20 20 regfull).....
9bc0: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
9bd0: 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 20 -tal newtal reg
9be0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
9bf0: 09 09 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 .... (runs:queu
9c00: 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 74 61 e-next-reg newta
9c10: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
9c20: 66 75 6c 6c 29 0a 09 09 09 09 20 20 72 65 72 75 full)..... reru
9c30: 6e 73 29 29 29 29 0a 09 09 20 20 20 20 20 28 65 ns))))... (e
9c40: 6c 73 65 0a 09 09 20 20 20 20 20 20 28 69 66 20 lse... (if
9c50: 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 (runs:lownoise (
9c60: 63 6f 6e 63 20 22 46 41 49 4c 45 44 20 70 72 65 conc "FAILED pre
9c70: 72 65 71 75 69 74 65 73 74 73 20 61 6e 64 20 77 requitests and w
9c80: 65 20 74 72 69 65 64 22 20 68 65 64 29 20 36 30 e tried" hed) 60
9c90: 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ).... (debug:pr
9ca0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
9cb0: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
9cc0: 20 46 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 FAILED prerequi
9cd0: 74 65 73 74 73 20 61 6e 64 20 77 65 27 76 65 20 tests and we've
9ce0: 74 72 69 65 64 20 61 74 20 6c 65 61 73 74 20 31 tried at least 1
9cf0: 30 20 74 69 6d 65 73 20 74 6f 20 72 75 6e 20 69 0 times to run i
9d00: 74 2e 20 47 69 76 69 6e 67 20 75 70 20 6e 6f 77 t. Giving up now
9d10: 2e 22 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 ."))... ;;
9d20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9d30: 20 20 20 20 20 20 20 20 20 70 72 65 72 65 71 73 prereqs
9d40: 3a 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d : " prereqs-not-
9d50: 6d 65 74 29 0a 09 09 20 20 20 20 20 20 28 68 61 met)... (ha
9d60: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
9d70: 73 74 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 st-registry hed
9d80: 27 72 65 6d 6f 76 65 64 29 0a 09 09 20 20 20 20 'removed)...
9d90: 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (mt:test-set-s
9da0: 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 tate-status-by-t
9db0: 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 estname run-id t
9dc0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
9dd0: 74 68 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 th "NOT_STARTED"
9de0: 20 22 54 45 4e 5f 53 54 52 49 4b 45 53 22 20 23 "TEN_STRIKES" #
9df0: 66 29 0a 09 09 20 20 20 20 20 20 28 6d 74 3a 72 f)... (mt:r
9e00: 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c oll-up-pass-fail
9e10: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
9e20: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
9e30: 74 68 20 22 46 41 49 4c 22 29 20 3b 3b 20 74 72 th "FAIL") ;; tr
9e40: 65 61 74 20 61 73 20 46 41 49 4c 0a 09 09 20 20 eat as FAIL...
9e50: 20 20 20 20 28 6c 69 73 74 20 28 69 66 20 28 6e (list (if (n
9e60: 75 6c 6c 3f 20 74 61 6c 29 28 63 61 72 20 6e 65 ull? tal)(car ne
9e70: 77 74 61 6c 29 28 63 61 72 20 74 61 6c 29 29 0a wtal)(car tal)).
9e80: 09 09 09 20 20 20 20 74 61 6c 0a 09 09 09 20 20 ... tal....
9e90: 20 20 72 65 67 0a 09 09 09 20 20 20 20 72 65 72 reg.... rer
9ea0: 75 6e 73 29 29 29 29 29 0a 09 20 20 20 20 20 20 uns)))))..
9eb0: 3b 3b 20 63 61 6e 27 74 20 64 72 6f 70 20 74 68 ;; can't drop th
9ec0: 69 73 20 2d 20 6d 61 79 62 65 20 72 75 6e 6e 69 is - maybe runni
9ed0: 6e 67 3f 20 4a 75 73 74 20 6b 65 65 70 20 74 72 ng? Just keep tr
9ee0: 79 69 6e 67 0a 09 20 20 20 20 20 20 28 6c 65 74 ying.. (let
9ef0: 20 28 28 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 ((runable-tests
9f00: 20 28 72 75 6e 73 3a 72 75 6e 61 62 6c 65 2d 74 (runs:runable-t
9f10: 65 73 74 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 ests prereqs-not
9f20: 2d 6d 65 74 29 29 29 0a 09 09 28 69 66 20 28 6e -met)))...(if (n
9f30: 75 6c 6c 3f 20 72 75 6e 61 62 6c 65 2d 74 65 73 ull? runable-tes
9f40: 74 73 29 0a 09 09 20 20 20 20 23 66 20 20 20 3b ts)... #f ;
9f50: 3b 20 49 20 74 68 69 6e 6b 20 77 65 20 61 72 65 ; I think we are
9f60: 20 74 72 75 6c 79 20 64 6f 6e 65 20 68 65 72 65 truly done here
9f70: 0a 09 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 ... (list (ru
9f80: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
9f90: 64 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 d newtal reg reg
9fa0: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
9fb0: 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d (runs:queue-
9fc0: 6e 65 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 next-tal newtal
9fd0: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
9fe0: 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 ll).... (runs
9ff0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
a000: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
a010: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
a020: 20 20 72 65 72 75 6e 73 29 29 29 29 29 29 29 29 reruns))))))))
a030: 29 0a 0a 3b 3b 20 73 63 61 6e 20 61 20 6c 69 73 )..;; scan a lis
a040: 74 20 6f 66 20 74 65 73 74 73 20 6c 6f 6f 6b 69 t of tests looki
a050: 6e 67 20 74 6f 20 73 65 65 20 69 66 20 61 6e 79 ng to see if any
a060: 20 61 72 65 20 70 6f 74 65 6e 74 69 61 6c 6c 79 are potentially
a070: 20 72 75 6e 6e 61 62 6c 65 0a 28 64 65 66 69 6e runnable.(defin
a080: 65 20 28 72 75 6e 73 3a 72 75 6e 61 62 6c 65 2d e (runs:runable-
a090: 74 65 73 74 73 20 74 65 73 74 73 29 0a 20 20 28 tests tests). (
a0a0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
a0b0: 74 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 t).. (if (not
a0c0: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 09 (vector? t))...
a0d0: 74 0a 09 09 28 6c 65 74 20 28 28 73 74 61 74 65 t...(let ((state
a0e0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
a0f0: 74 61 74 65 20 74 29 29 0a 09 09 20 20 20 20 20 tate t))...
a100: 20 28 73 74 61 74 75 73 20 28 64 62 3a 74 65 73 (status (db:tes
a110: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 t-get-status t))
a120: 29 0a 09 09 20 20 28 63 61 73 65 20 28 73 74 72 )... (case (str
a130: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 ing->symbol stat
a140: 65 29 0a 09 09 20 20 20 20 28 28 43 4f 4d 50 4c e)... ((COMPL
a150: 45 54 45 44 29 20 23 66 29 0a 09 09 20 20 20 20 ETED) #f)...
a160: 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 0a 09 ((NOT_STARTED)..
a170: 09 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 . (if (membe
a180: 72 20 73 74 61 74 75 73 20 27 28 22 54 45 4e 5f r status '("TEN_
a190: 53 54 52 49 4b 45 53 22 20 22 42 4c 4f 43 4b 45 STRIKES" "BLOCKE
a1a0: 44 22 20 22 50 52 45 51 5f 46 41 49 4c 22 20 22 D" "PREQ_FAIL" "
a1b0: 5a 45 52 4f 5f 49 54 45 4d 53 22 20 22 50 52 45 ZERO_ITEMS" "PRE
a1c0: 51 5f 44 49 53 43 41 52 44 45 44 22 20 22 54 49 Q_DISCARDED" "TI
a1d0: 4d 45 44 5f 4f 55 54 22 20 29 29 0a 09 09 09 20 MED_OUT" ))....
a1e0: 23 66 0a 09 09 09 20 74 29 29 0a 09 09 20 20 20 #f.... t))...
a1f0: 20 28 28 44 45 4c 45 54 45 44 29 20 23 66 29 0a ((DELETED) #f).
a200: 09 09 20 20 20 20 28 65 6c 73 65 20 74 29 29 29 .. (else t)))
a210: 29 29 0a 09 20 20 74 65 73 74 73 29 29 0a 0a 3b )).. tests))..;
a220: 3b 20 65 76 65 72 79 20 74 69 6d 65 20 74 68 6f ; every time tho
a230: 75 67 68 20 74 68 65 20 6c 6f 6f 70 20 69 6e 63 ugh the loop inc
a240: 72 65 6d 65 6e 74 20 74 68 65 20 74 65 73 74 2f rement the test/
a250: 69 74 65 6d 70 61 74 74 20 76 61 6c 2e 0a 3b 3b itempatt val..;;
a260: 20 77 68 65 6e 20 74 68 65 20 6d 69 6e 20 69 73 when the min is
a270: 20 3e 20 6d 61 78 2d 61 6c 6c 6f 77 65 64 20 61 > max-allowed a
a280: 6e 64 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 20 nd none running
a290: 74 68 65 6e 20 66 6f 72 63 65 20 65 78 69 74 0a then force exit.
a2a0: 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d ;;.(define *max-
a2b0: 74 72 69 65 73 2d 68 61 73 68 2a 20 28 6d 61 6b tries-hash* (mak
a2c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a e-hash-table))..
a2d0: 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ;; test-records
a2e0: 69 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 is a hash table
a2f0: 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 testname:item_pa
a300: 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 th => vector < t
a310: 65 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 estname testconf
a320: 69 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 ig waitons prior
a330: 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e ity items-info .
a340: 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 .. >.(define (ru
a350: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 ns:run-tests-que
a360: 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d ue run-id runnam
a370: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b e test-records k
a380: 65 79 76 61 6c 73 20 66 6c 61 67 73 20 74 65 73 eyvals flags tes
a390: 74 2d 70 61 74 74 73 20 72 65 71 75 69 72 65 64 t-patts required
a3a0: 2d 74 65 73 74 73 20 72 65 67 6c 65 6e 2d 69 6e -tests reglen-in
a3b0: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
a3c0: 74 72 79 29 0a 20 20 3b 3b 20 41 74 20 74 68 69 try). ;; At thi
a3d0: 73 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 73 74 s point the list
a3e0: 20 6f 66 20 70 61 72 65 6e 74 20 74 65 73 74 73 of parent tests
a3f0: 20 69 73 20 65 78 70 61 6e 64 65 64 20 0a 20 20 is expanded .
a400: 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 65 ;; NB// Should e
a410: 78 70 61 6e 64 20 69 74 65 6d 73 20 68 65 72 65 xpand items here
a420: 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 65 72 74 and then insert
a430: 20 69 6e 74 6f 20 74 68 65 20 72 75 6e 20 71 75 into the run qu
a440: 65 75 65 2e 0a 20 20 28 64 65 62 75 67 3a 70 72 eue.. (debug:pr
a450: 69 6e 74 20 35 20 22 74 65 73 74 2d 72 65 63 6f int 5 "test-reco
a460: 72 64 73 3a 20 22 20 74 65 73 74 2d 72 65 63 6f rds: " test-reco
a470: 72 64 73 20 22 2c 20 66 6c 61 67 73 3a 20 22 20 rds ", flags: "
a480: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
a490: 73 74 20 66 6c 61 67 73 29 29 0a 0a 20 20 3b 3b st flags)).. ;;
a4a0: 20 44 6f 20 6d 61 72 6b 2d 61 6e 64 2d 66 69 6e Do mark-and-fin
a4b0: 64 20 63 6c 65 61 6e 20 75 70 20 6f 66 20 64 62 d clean up of db
a4c0: 20 62 65 66 6f 72 65 20 73 74 61 72 74 69 6e 67 before starting
a4d0: 20 72 75 6e 69 6e 67 20 6f 66 20 71 75 75 65 0a runing of quue.
a4e0: 20 20 3b 3b 0a 20 20 3b 3b 20 28 63 64 62 3a 72 ;;. ;; (cdb:r
a4f0: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 66 69 6e emote-run db:fin
a500: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
a510: 70 6c 65 74 65 20 23 66 29 0a 0a 20 20 28 6c 65 plete #f).. (le
a520: 74 20 28 28 72 75 6e 2d 69 6e 66 6f 20 20 20 20 t ((run-info
a530: 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 (rmt:g
a540: 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d et-run-info run-
a550: 69 64 29 29 0a 09 28 74 65 73 74 73 2d 69 6e 66 id))..(tests-inf
a560: 6f 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 74 o (mt
a570: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
a580: 75 6e 20 72 75 6e 2d 69 64 20 23 66 20 27 28 29 un run-id #f '()
a590: 20 27 28 29 29 29 20 3b 3b 20 20 71 72 79 76 61 '())) ;; qryva
a5a0: 6c 73 3a 20 22 69 64 2c 74 65 73 74 6e 61 6d 65 ls: "id,testname
a5b0: 2c 69 74 65 6d 5f 70 61 74 68 22 29 29 0a 09 28 ,item_path"))..(
a5c0: 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 sorted-test-name
a5d0: 73 20 20 20 20 20 28 74 65 73 74 73 3a 73 6f 72 s (tests:sor
a5e0: 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e t-by-priority-an
a5f0: 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 d-waiton test-re
a600: 63 6f 72 64 73 29 29 0a 09 28 74 65 73 74 2d 72 cords))..(test-r
a610: 65 67 69 73 74 72 79 20 20 20 20 20 20 20 20 20 egistry
a620: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
a630: 29 29 0a 09 28 72 65 67 69 73 74 72 79 2d 6d 75 ))..(registry-mu
a640: 74 65 78 20 20 20 20 20 20 20 20 28 6d 61 6b 65 tex (make
a650: 2d 6d 75 74 65 78 29 29 0a 09 28 6e 75 6d 2d 72 -mutex))..(num-r
a660: 65 74 72 69 65 73 20 20 20 20 20 20 20 20 20 20 etries
a670: 20 30 29 0a 09 28 6d 61 78 2d 72 65 74 72 69 65 0)..(max-retrie
a680: 73 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e s (con
a690: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
a6a0: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
a6b0: 6d 61 78 72 65 74 72 69 65 73 22 29 29 0a 09 28 maxretries"))..(
a6c0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
a6d0: 6f 62 73 20 20 20 28 6c 65 74 20 28 28 6d 63 6a obs (let ((mcj
a6e0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
a6f0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
a700: 75 70 22 20 20 20 20 20 22 6d 61 78 5f 63 6f 6e up" "max_con
a710: 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 29 current_jobs")))
a720: 0a 09 09 09 09 20 28 69 66 20 28 61 6e 64 20 6d ..... (if (and m
a730: 63 6a 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 cj (string->numb
a740: 65 72 20 6d 63 6a 29 29 0a 09 09 09 09 20 20 20 er mcj)).....
a750: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
a760: 72 20 6d 63 6a 29 0a 09 09 09 09 20 20 20 20 20 r mcj).....
a770: 31 29 29 29 20 3b 3b 20 6c 65 6e 67 74 68 20 6f 1))) ;; length o
a780: 66 20 74 68 65 20 72 65 67 69 73 74 65 72 20 71 f the register q
a790: 75 65 75 65 20 61 68 65 61 64 0a 09 28 72 65 67 ueue ahead..(reg
a7a0: 6c 65 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 len
a7b0: 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 (if (number?
a7c0: 72 65 67 6c 65 6e 2d 69 6e 29 20 72 65 67 6c 65 reglen-in) regle
a7d0: 6e 2d 69 6e 20 31 29 29 0a 09 28 6c 61 73 74 2d n-in 1))..(last-
a7e0: 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 time-incomplete
a7f0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
a800: 6f 6e 64 73 29 20 39 30 30 29 29 20 3b 3b 20 66 onds) 900)) ;; f
a810: 6f 72 63 65 20 61 74 20 6c 65 61 73 74 20 6f 6e orce at least on
a820: 65 20 63 6c 65 61 6e 20 75 70 20 63 79 63 6c 65 e clean up cycle
a830: 0a 09 28 6c 61 73 74 2d 74 69 6d 65 2d 73 6f 6d ..(last-time-som
a840: 65 2d 72 75 6e 6e 69 6e 67 20 28 63 75 72 72 65 e-running (curre
a850: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 0a 20 nt-seconds)))..
a860: 20 20 20 3b 3b 20 49 6e 69 74 69 61 6c 69 7a 65 ;; Initialize
a870: 20 74 68 65 20 74 65 73 74 2d 72 65 67 69 73 74 the test-regist
a880: 65 72 79 20 68 61 73 68 20 77 69 74 68 20 74 65 ery hash with te
a890: 73 74 73 20 74 68 61 74 20 61 6c 72 65 61 64 79 sts that already
a8a0: 20 68 61 76 65 20 61 20 72 65 63 6f 72 64 0a 20 have a record.
a8b0: 20 20 20 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 ;; convert st
a8c0: 61 74 65 20 74 6f 20 73 79 6d 62 6f 6c 20 61 6e ate to symbol an
a8d0: 64 20 75 73 65 20 74 68 61 74 20 61 73 20 74 68 d use that as th
a8e0: 65 20 68 61 73 68 20 76 61 6c 75 65 0a 20 20 20 e hash value.
a8f0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
a900: 64 61 20 28 74 72 65 63 29 0a 09 09 28 6c 65 74 da (trec)...(let
a910: 20 28 28 69 64 20 28 64 62 3a 74 65 73 74 2d 67 ((id (db:test-g
a920: 65 74 2d 69 64 20 20 20 20 20 20 20 20 74 72 65 et-id tre
a930: 63 29 29 0a 09 09 20 20 20 20 20 20 28 74 6e 20 c))... (tn
a940: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
a950: 74 6e 61 6d 65 20 20 74 72 65 63 29 29 0a 09 09 tname trec))...
a960: 20 20 20 20 20 20 28 69 70 20 28 64 62 3a 74 65 (ip (db:te
a970: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
a980: 20 74 72 65 63 29 29 0a 09 09 20 20 20 20 20 20 trec))...
a990: 28 73 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (st (db:test-get
a9a0: 2d 73 74 61 74 65 20 20 20 20 20 74 72 65 63 29 -state trec)
a9b0: 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 ))... (if (not
a9c0: 28 65 71 75 61 6c 3f 20 73 74 20 22 44 45 4c 45 (equal? st "DELE
a9d0: 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 20 28 TED"))... (
a9e0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
a9f0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
aa00: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
aa10: 73 74 2d 6e 61 6d 65 20 74 6e 20 69 70 29 20 28 st-name tn ip) (
aa20: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 string->symbol s
aa30: 74 29 29 29 29 29 0a 09 20 20 20 20 20 20 74 65 t))))).. te
aa40: 73 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 28 73 sts-info). (s
aa50: 65 74 21 20 6d 61 78 2d 72 65 74 72 69 65 73 20 et! max-retries
aa60: 28 69 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 (if (and max-ret
aa70: 72 69 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 ries (string->nu
aa80: 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 mber max-retries
aa90: 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ))(string->numbe
aaa0: 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 20 31 r max-retries) 1
aab0: 30 30 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 6c 00)).. (let l
aac0: 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 20 oop ((hed
aad0: 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 (car sorted-te
aae0: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 st-names))..
aaf0: 20 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 (tal
ab00: 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (cdr sorted-test
ab10: 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 20 -names))..
ab20: 20 28 72 65 67 20 20 20 20 20 20 20 20 20 27 28 (reg '(
ab30: 29 29 20 3b 3b 20 72 65 67 69 73 74 65 72 65 64 )) ;; registered
ab40: 2c 20 70 75 74 20 74 68 65 73 65 20 61 74 20 74 , put these at t
ab50: 68 65 20 68 65 61 64 20 6f 66 20 74 61 6c 20 0a he head of tal .
ab60: 09 20 20 20 20 20 20 20 28 72 65 72 75 6e 73 20 . (reruns
ab70: 20 20 20 20 20 27 28 29 29 29 0a 0a 20 20 20 20 '()))..
ab80: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
ab90: 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 67 ? reruns))(debug
aba0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
abb0: 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 eruns=" reruns))
abc0: 0a 0a 20 20 20 20 20 20 3b 3b 20 48 65 72 65 20 .. ;; Here
abd0: 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f 6c 64 20 we mark any old
abe0: 64 65 66 75 6e 63 74 20 74 65 73 74 73 20 61 73 defunct tests as
abf0: 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 44 6f 20 incomplete. Do
ac00: 74 68 69 73 20 65 76 65 72 79 20 66 69 66 74 65 this every fifte
ac10: 65 6e 20 6d 69 6e 75 74 65 73 0a 20 20 20 20 20 en minutes.
ac20: 20 3b 3b 20 6d 6f 76 69 6e 67 20 74 68 69 73 20 ;; moving this
ac30: 74 6f 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 to a parallel th
ac40: 72 65 61 64 20 61 6e 64 20 6a 75 73 74 20 72 75 read and just ru
ac50: 6e 20 69 74 20 6f 6e 63 65 2e 0a 20 20 20 20 20 n it once..
ac60: 20 3b 3b 0a 20 20 20 20 20 20 28 69 66 20 28 3e ;;. (if (>
ac70: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
ac80: 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 69 s)(+ last-time-i
ac90: 6e 63 6f 6d 70 6c 65 74 65 20 39 30 30 29 29 0a ncomplete 900)).
aca0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
acb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 . (se
acc0: 74 21 20 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 t! last-time-inc
acd0: 6f 6d 70 6c 65 74 65 20 28 63 75 72 72 65 6e 74 omplete (current
ace0: 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 -seconds)).
acf0: 20 20 20 20 20 20 20 3b 3b 20 28 72 6d 74 3a 66 ;; (rmt:f
ad00: 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 ind-and-mark-inc
ad10: 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 omplete-all-runs
ad20: 29 0a 09 20 20 20 20 29 29 0a 0a 20 20 20 20 20 ).. ))..
ad30: 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f 70 20 ;; (print "Top
ad40: 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 68 of loop, hed=" h
ad50: 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c 20 ed ", tal=" tal
ad60: 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 72 75 " ,reruns=" reru
ad70: 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 ns). (let*
ad80: 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 ((test-record (h
ad90: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
ada0: 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 st-records hed))
adb0: 0a 09 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d .. (test-nam
adc0: 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 e (tests:testq
add0: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
ade0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a e test-record)).
adf0: 09 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 20 . (tconfig
ae00: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
ae10: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
ae20: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
ae30: 0a 09 20 20 20 20 20 28 6a 6f 62 67 72 6f 75 70 .. (jobgroup
ae40: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
ae50: 75 70 20 74 63 6f 6e 66 69 67 20 22 74 65 73 74 up tconfig "test
ae60: 5f 6d 65 74 61 22 20 22 6a 6f 62 67 72 6f 75 70 _meta" "jobgroup
ae70: 22 29 29 0a 09 20 20 20 20 20 28 74 65 73 74 6d ")).. (testm
ae80: 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d 20 ode (let ((m
ae90: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
aea0: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
aeb0: 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 0a ents" "mode"))).
aec0: 09 09 09 20 20 20 20 28 69 66 20 6d 20 28 6d 61 ... (if m (ma
aed0: 70 20 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c p string->symbol
aee0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6d (string-split m
aef0: 29 29 20 27 28 6e 6f 72 6d 61 6c 29 29 29 29 0a )) '(normal)))).
af00: 09 20 20 20 20 20 28 69 74 65 6d 6d 61 70 20 20 . (itemmap
af10: 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b (configf:look
af20: 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 up tconfig "requ
af30: 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d 6d irements" "itemm
af40: 61 70 22 29 29 0a 09 20 20 20 20 20 28 77 61 69 ap")).. (wai
af50: 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a tons (tests:
af60: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
af70: 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 itons test-re
af80: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 70 72 cord)).. (pr
af90: 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 73 iority (tests
afa0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 :testqueue-get-p
afb0: 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 riority test-r
afc0: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 69 ecord)).. (i
afd0: 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 temdat (test
afe0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
aff0: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
b000: 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d record)) ;; item
b010: 64 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 dat can be a str
b020: 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a ing, list or #f.
b030: 09 20 20 20 20 20 28 69 74 65 6d 73 20 20 20 20 . (items
b040: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
b050: 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 20 20 20 eue-get-items
b060: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
b070: 0a 09 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 .. (item-pat
b080: 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e h (item-list->
b090: 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 path itemdat))..
b0a0: 20 20 20 20 20 28 74 66 75 6c 6c 6e 61 6d 65 20 (tfullname
b0b0: 20 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c (runs:make-ful
b0c0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
b0d0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
b0e0: 29 0a 09 20 20 20 20 20 28 6e 65 77 74 61 6c 20 ).. (newtal
b0f0: 20 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c (append tal
b100: 20 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 20 (list hed)))..
b110: 20 20 20 20 28 72 65 67 66 75 6c 6c 20 20 20 20 (regfull
b120: 20 28 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 67 (>= (length reg
b130: 29 20 72 65 67 6c 65 6e 29 29 0a 09 20 20 20 20 ) reglen))..
b140: 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 72 (num-running (r
b150: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
b160: 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 ts-running-for-r
b170: 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 29 29 0a un-id run-id))).
b180: 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 . (if (> nu
b190: 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 0a 09 20 20 m-running 0)..
b1a0: 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 2d (set! last-time-
b1b0: 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 63 75 some-running (cu
b1c0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
b1d0: 0a 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 .. (if (> (
b1e0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
b1f0: 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 73 6f 6d (+ last-time-som
b200: 65 2d 72 75 6e 6e 69 6e 67 20 32 34 30 29 29 0a e-running 240)).
b210: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
b220: 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 et! *max-tries-h
b230: 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 28 ash* tfullname (
b240: 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 + (hash-table-re
b250: 66 2f 64 65 66 61 75 6c 74 20 2a 6d 61 78 2d 74 f/default *max-t
b260: 72 69 65 73 2d 68 61 73 68 2a 20 74 66 75 6c 6c ries-hash* tfull
b270: 6e 61 6d 65 20 30 29 20 31 29 29 29 0a 09 3b 3b name 0) 1)))..;;
b280: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
b290: 22 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 3a "max-tries-hash:
b2a0: 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e " (hash-table->
b2b0: 61 6c 69 73 74 20 2a 6d 61 78 2d 74 72 69 65 73 alist *max-tries
b2c0: 2d 68 61 73 68 2a 29 29 0a 0a 09 3b 3b 20 45 6e -hash*))...;; En
b2d0: 73 75 72 65 20 61 6c 6c 20 74 6f 70 20 6c 65 76 sure all top lev
b2e0: 65 6c 20 74 65 73 74 73 20 67 65 74 20 72 65 67 el tests get reg
b2f0: 69 73 74 65 72 65 64 2e 20 54 68 69 73 20 77 61 istered. This wa
b300: 79 20 74 68 65 79 20 73 68 6f 77 20 75 70 20 61 y they show up a
b310: 73 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 s "NOT_STARTED"
b320: 6f 6e 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 on the dashboard
b330: 0a 09 3b 3b 20 61 6e 64 20 69 74 20 69 73 20 63 ..;; and it is c
b340: 6c 65 61 72 20 74 68 65 79 20 2a 73 68 6f 75 6c lear they *shoul
b350: 64 2a 20 68 61 76 65 20 72 75 6e 20 62 75 74 20 d* have run but
b360: 64 69 64 20 6e 6f 74 2e 0a 09 28 69 66 20 28 6e did not...(if (n
b370: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
b380: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
b390: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m
b3a0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
b3b0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 me test-name "")
b3c0: 20 23 66 29 29 0a 09 20 20 20 20 28 62 65 67 69 #f)).. (begi
b3d0: 6e 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 67 65 n.. (rmt:ge
b3e0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 neral-call 'regi
b3f0: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
b400: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
b410: 65 20 22 22 29 0a 09 20 20 20 20 20 20 28 68 61 e "").. (ha
b420: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
b430: 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e st-registry (run
b440: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
b450: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
b460: 22 22 29 20 27 64 6f 6e 65 29 29 29 0a 09 0a 09 "") 'done)))....
b470: 3b 3b 20 46 61 73 74 20 73 6b 69 70 20 6f 66 20 ;; Fast skip of
b480: 74 65 73 74 73 20 74 68 61 74 20 61 72 65 20 61 tests that are a
b490: 6c 72 65 61 64 79 20 22 43 4f 4d 50 4c 45 54 45 lready "COMPLETE
b4a0: 44 22 20 2d 20 4e 4f 21 20 43 61 6e 6e 6f 74 20 D" - NO! Cannot
b4b0: 64 6f 20 74 68 61 74 20 61 73 20 74 68 65 20 69 do that as the i
b4c0: 74 65 6d 73 20 6d 61 79 20 6e 6f 74 20 68 61 76 tems may not hav
b4d0: 65 20 62 65 65 6e 20 65 78 70 61 6e 64 65 64 20 e been expanded
b4e0: 79 65 74 20 3a 28 0a 09 3b 3b 0a 09 28 69 66 20 yet :(..;;..(if
b4f0: 28 6d 65 6d 62 65 72 20 28 68 61 73 68 2d 74 61 (member (hash-ta
b500: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
b510: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 66 test-registry tf
b520: 75 6c 6c 6e 61 6d 65 20 23 66 29 20 0a 09 09 20 ullname #f) ...
b530: 20 20 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 '(DONOTRUN re
b540: 6d 6f 76 65 64 29 29 20 3b 3b 20 2a 63 6f 6d 6d moved)) ;; *comm
b550: 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 on:cant-run-stat
b560: 65 73 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 43 4f es-sym*) ;; '(CO
b570: 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 MPLETED KILLED W
b580: 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e AIVED UNKNOWN IN
b590: 43 4f 4d 50 4c 45 54 45 29 29 0a 09 20 20 20 20 COMPLETE))..
b5a0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 69 (begin.. (i
b5b0: 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 f (runs:lownoise
b5c0: 20 28 63 6f 6e 63 20 22 62 65 65 6e 20 6d 61 72 (conc "been mar
b5d0: 6b 65 64 20 64 6f 20 6e 6f 74 20 72 75 6e 20 22 ked do not run "
b5e0: 20 74 66 75 6c 6c 6e 61 6d 65 29 20 36 30 29 0a tfullname) 60).
b5f0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
b600: 2d 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e -info 0 "Skippin
b610: 67 20 74 65 73 74 20 22 20 74 66 75 6c 6c 6e 61 g test " tfullna
b620: 6d 65 20 22 20 61 73 20 69 74 20 68 61 73 20 62 me " as it has b
b630: 65 65 6e 20 6d 61 72 6b 65 64 20 64 6f 20 6e 6f een marked do no
b640: 74 20 72 75 6e 20 64 75 65 20 74 6f 20 62 65 69 t run due to bei
b650: 6e 67 20 63 6f 6d 70 6c 65 74 65 64 20 6f 72 20 ng completed or
b660: 6e 6f 74 20 72 75 6e 6e 61 62 6c 65 22 29 29 0a not runnable")).
b670: 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 . (if (or (
b680: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
b690: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
b6a0: 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 75 ))... (loop (ru
b6b0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
b6c0: 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e d tal reg reglen
b6d0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 75 regfull)....(ru
b6e0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 ns:queue-next-ta
b6f0: 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e l tal reg reglen
b700: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 75 regfull)....(ru
b710: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 ns:queue-next-re
b720: 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e g tal reg reglen
b730: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 72 65 72 regfull)....rer
b740: 75 6e 73 29 29 29 29 0a 09 09 20 20 3b 3b 20 28 uns))))... ;; (
b750: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
b760: 64 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 dr tal) reg reru
b770: 6e 73 29 29 29 29 0a 0a 09 28 64 65 62 75 67 3a ns))))...(debug:
b780: 70 72 69 6e 74 20 34 20 22 54 4f 50 20 4f 46 20 print 4 "TOP OF
b790: 4c 4f 4f 50 20 3d 3e 20 22 0a 09 09 20 20 20 20 LOOP => "...
b7a0: 20 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 "test-name: " t
b7b0: 65 73 74 2d 6e 61 6d 65 0a 09 09 20 20 20 20 20 est-name...
b7c0: 22 5c 6e 20 20 74 65 73 74 2d 72 65 63 6f 72 64 "\n test-record
b7d0: 20 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 0a " test-record.
b7e0: 09 09 20 20 20 20 20 22 5c 6e 20 20 68 65 64 3a .. "\n hed:
b7f0: 20 20 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 " hed..
b800: 09 20 20 20 20 20 22 5c 6e 20 20 69 74 65 6d 64 . "\n itemd
b810: 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 at: " itemda
b820: 74 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 74 t... "\n it
b830: 65 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 ems: " ite
b840: 6d 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 ms... "\n i
b850: 74 65 6d 2d 70 61 74 68 3a 20 20 20 22 20 69 74 tem-path: " it
b860: 65 6d 2d 70 61 74 68 0a 09 09 20 20 20 20 20 22 em-path... "
b870: 5c 6e 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 20 \n waitons:
b880: 20 22 20 77 61 69 74 6f 6e 73 0a 09 09 20 20 20 " waitons...
b890: 20 20 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 69 "\n num-retri
b8a0: 65 73 3a 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 es: " num-retrie
b8b0: 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 74 61 s... "\n ta
b8c0: 6c 3a 20 20 20 20 20 20 20 20 20 22 20 74 61 6c l: " tal
b8d0: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 72 ... "\n rer
b8e0: 75 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 75 uns: " reru
b8f0: 6e 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 ns... "\n r
b900: 65 67 66 75 6c 6c 3a 20 20 20 20 20 22 20 72 65 egfull: " re
b910: 67 66 75 6c 6c 0a 09 09 20 20 20 20 20 22 5c 6e gfull... "\n
b920: 20 20 72 65 67 6c 65 6e 3a 20 20 20 20 20 20 22 reglen: "
b930: 20 72 65 67 6c 65 6e 0a 09 09 20 20 20 20 20 22 reglen... "
b940: 5c 6e 20 20 6c 65 6e 67 74 68 20 72 65 67 3a 20 \n length reg:
b950: 20 22 20 28 6c 65 6e 67 74 68 20 72 65 67 29 0a " (length reg).
b960: 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 67 3a .. "\n reg:
b970: 20 20 20 20 20 20 20 20 20 22 20 72 65 67 29 0a " reg).
b980: 0a 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 ..;; check for h
b990: 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e ed in waitons =>
b9a0: 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 this would be c
b9b0: 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 ircular, remove
b9c0: 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a it and issue an.
b9d0: 09 3b 3b 20 65 72 72 6f 72 0a 09 28 69 66 20 28 .;; error..(if (
b9e0: 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 member test-name
b9f0: 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 waitons).. (
ba00: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
ba10: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
ba20: 4f 52 3a 20 74 65 73 74 20 22 20 74 65 73 74 2d OR: test " test-
ba30: 6e 61 6d 65 20 22 20 68 61 73 20 6c 69 73 74 65 name " has liste
ba40: 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 d itself as a wa
ba50: 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 iton, please cor
ba60: 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 20 20 rect this!")..
ba70: 20 20 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e (set! waiton
ba80: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
ba90: 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f (x)(not (equal?
baa0: 20 78 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e x hed))) waiton
bab0: 73 29 29 29 29 0a 0a 09 28 63 6f 6e 64 20 0a 09 s))))...(cond ..
bac0: 20 0a 09 20 3b 3b 20 57 65 20 77 61 6e 74 20 74 .. ;; We want t
bad0: 6f 20 63 61 74 63 68 20 74 65 73 74 73 20 74 68 o catch tests th
bae0: 61 74 20 68 61 76 65 20 77 61 69 74 6f 6e 73 20 at have waitons
baf0: 74 68 61 74 20 61 72 65 20 4e 4f 54 20 69 6e 20 that are NOT in
bb00: 74 68 65 20 71 75 65 75 65 20 61 6e 64 20 64 69 the queue and di
bb10: 73 63 61 72 64 20 74 68 65 6d 20 49 46 46 20 0a scard them IFF .
bb20: 09 20 3b 3b 20 74 68 65 79 20 68 61 76 65 20 62 . ;; they have b
bb30: 65 65 6e 20 74 68 72 6f 75 67 68 20 74 68 65 20 een through the
bb40: 77 72 69 6e 67 65 72 20 31 30 20 6f 72 20 6d 6f wringer 10 or mo
bb50: 72 65 20 74 69 6d 65 73 0a 09 20 28 28 61 6e 64 re times.. ((and
bb60: 20 28 6c 69 73 74 3f 20 77 61 69 74 6f 6e 73 29 (list? waitons)
bb70: 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6e .. (not (n
bb80: 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 29 0a 09 ull? waitons))..
bb90: 20 20 20 20 20 20 20 28 3e 20 28 68 61 73 68 2d (> (hash-
bba0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
bbb0: 74 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 t *max-tries-has
bbc0: 68 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 30 29 20 h* tfullname 0)
bbd0: 31 30 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 10).. (not
bbe0: 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 0a (null? (filter.
bbf0: 09 09 09 20 20 20 20 6e 75 6d 62 65 72 3f 0a 09 ... number?..
bc00: 09 09 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 .. (map (lamb
bc10: 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 09 da (waiton).....
bc20: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
bc30: 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 (member waiton
bc40: 74 61 6c 29 29 20 20 20 20 20 20 20 20 20 20 20 tal))
bc50: 20 3b 3b 20 74 68 69 73 20 77 61 69 74 6f 6e 20 ;; this waiton
bc60: 69 73 20 6e 6f 74 20 69 6e 20 74 68 65 20 6c 69 is not in the li
bc70: 73 74 20 74 6f 20 62 65 20 74 72 69 65 64 20 74 st to be tried t
bc80: 6f 20 72 75 6e 0a 09 09 09 09 09 20 20 20 20 28 o run...... (
bc90: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 not (member wait
bca0: 6f 6e 20 72 65 72 75 6e 73 29 29 29 0a 09 09 09 on reruns)))....
bcb0: 09 20 20 20 20 20 20 20 31 0a 09 09 09 09 20 20 . 1.....
bcc0: 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 77 #f))..... w
bcd0: 61 69 74 6f 6e 73 29 29 29 29 29 20 3b 3b 20 63 aitons))))) ;; c
bce0: 6f 75 6c 64 20 64 6f 20 74 68 69 73 20 6d 6f 72 ould do this mor
bcf0: 65 20 65 6c 65 67 61 6e 74 6c 79 20 77 69 74 68 e elegantly with
bd00: 20 61 20 6d 61 72 6b 65 72 2e 2e 2e 2e 0a 09 20 a marker......
bd10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
bd20: 22 57 41 52 4e 49 4e 47 3a 20 4d 61 72 6b 69 6e "WARNING: Markin
bd30: 67 20 74 65 73 74 20 22 20 74 66 75 6c 6c 6e 61 g test " tfullna
bd40: 6d 65 20 22 20 61 73 20 6e 6f 74 20 72 75 6e 6e me " as not runn
bd50: 61 62 6c 65 2e 20 49 74 20 69 73 20 77 61 69 74 able. It is wait
bd60: 69 6e 67 20 6f 6e 20 74 65 73 74 73 20 74 68 61 ing on tests tha
bd70: 74 20 63 61 6e 6e 6f 74 20 62 65 20 72 75 6e 2e t cannot be run.
bd80: 20 47 69 76 69 6e 67 20 75 70 20 6e 6f 77 2e 22 Giving up now."
bd90: 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ).. (hash-table
bda0: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
bdb0: 74 72 79 20 74 66 75 6c 6c 6e 61 6d 65 20 27 72 try tfullname 'r
bdc0: 65 6d 6f 76 65 64 29 29 0a 0a 09 20 3b 3b 20 69 emoved))... ;; i
bdd0: 74 65 6d 73 20 69 73 20 23 66 20 74 68 65 6e 20 tems is #f then
bde0: 74 68 65 20 74 65 73 74 20 69 73 20 6f 6b 20 74 the test is ok t
bdf0: 6f 20 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 o be handed off
be00: 74 6f 20 6c 61 75 6e 63 68 20 28 62 75 74 20 6e to launch (but n
be10: 6f 74 20 62 65 66 6f 72 65 29 0a 09 20 3b 3b 20 ot before).. ;;
be20: 0a 09 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 0a .. ((not items).
be30: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
be40: 69 6e 66 6f 20 34 20 22 4f 55 54 45 52 20 43 4f info 4 "OUTER CO
be50: 4e 44 3a 20 28 6e 6f 74 20 69 74 65 6d 73 29 22 ND: (not items)"
be60: 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e ).. (if (and (n
be70: 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 ot (tests:match
be80: 74 65 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 test-patts (test
be90: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
bea0: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
beb0: 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 68 20 cord) item-path
bec0: 72 65 71 75 69 72 65 64 3a 20 72 65 71 75 69 72 required: requir
bed0: 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 ed-tests))...
bee0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
bef0: 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )).. (loop
bf00: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
bf10: 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a l) reg reruns)).
bf20: 09 20 20 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c . (let ((loop-l
bf30: 69 73 74 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 ist (runs:proces
bf40: 73 2d 65 78 70 61 6e 64 65 64 2d 74 65 73 74 73 s-expanded-tests
bf50: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
bf60: 75 6e 73 20 72 65 67 6c 65 6e 20 72 65 67 66 75 uns reglen regfu
bf70: 6c 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 20 72 ll test-record r
bf80: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 unname test-name
bf90: 20 69 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 item-path jobgr
bfa0: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
bfb0: 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 nt-jobs run-id w
bfc0: 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 aitons item-path
bfd0: 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 testmode test-p
bfe0: 61 74 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 atts required-te
bff0: 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 sts test-registr
c000: 79 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 y registry-mutex
c010: 20 66 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 72 flags keyvals r
c020: 75 6e 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 un-info newtal a
c030: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
c040: 79 20 69 74 65 6d 6d 61 70 29 29 29 0a 09 20 20 y itemmap)))..
c050: 20 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 20 (if loop-list
c060: 28 61 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 (apply loop loop
c070: 2d 6c 69 73 74 29 29 29 29 0a 0a 09 20 3b 3b 20 -list))))... ;;
c080: 69 74 65 6d 73 20 70 72 6f 63 65 73 73 65 64 20 items processed
c090: 69 6e 74 6f 20 61 20 6c 69 73 74 20 62 75 74 20 into a list but
c0a0: 6e 6f 74 20 63 61 6d 65 20 69 6e 20 61 73 20 61 not came in as a
c0b0: 20 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 65 list been proce
c0c0: 73 73 65 64 0a 09 20 3b 3b 0a 09 20 28 28 61 6e ssed.. ;;.. ((an
c0d0: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
c0e0: 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b ;; thus we k
c0f0: 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 now our items ar
c100: 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c e already calcul
c110: 61 74 65 64 0a 09 20 20 20 20 20 20 20 28 6e 6f ated.. (no
c120: 74 20 20 20 69 74 65 6d 64 61 74 29 29 20 20 3b t itemdat)) ;
c130: 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 78 ; and not yet ex
c140: 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 20 panded into the
c150: 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 74 list of things t
c160: 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 28 64 65 o be done.. (de
c170: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
c180: 20 22 4f 55 54 45 52 20 43 4f 4e 44 3a 20 28 61 "OUTER COND: (a
c190: 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 nd (list? items)
c1a0: 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 29 22 29 (not itemdat))")
c1b0: 0a 09 20 20 3b 3b 20 4d 75 73 74 20 64 65 74 65 .. ;; Must dete
c1c0: 72 6d 69 6e 65 20 69 66 20 74 68 65 20 69 74 65 rmine if the ite
c1d0: 6d 73 20 6c 69 73 74 20 69 73 20 76 61 6c 69 64 ms list is valid
c1e0: 2e 20 44 69 73 63 61 72 64 20 74 68 65 20 74 65 . Discard the te
c1f0: 73 74 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e st if it is not.
c200: 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 .. (if (and (li
c210: 73 74 3f 20 69 74 65 6d 73 29 0a 09 09 20 20 20 st? items)...
c220: 28 3e 20 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 (> (length items
c230: 29 20 30 29 0a 09 09 20 20 20 28 61 6e 64 20 28 ) 0)... (and (
c240: 6c 69 73 74 3f 20 28 63 61 72 20 69 74 65 6d 73 list? (car items
c250: 29 29 0a 09 09 09 28 3e 20 28 6c 65 6e 67 74 68 ))....(> (length
c260: 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 (car items)) 0)
c270: 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 64 65 )... (debug:de
c280: 62 75 67 2d 6d 6f 64 65 20 31 29 29 0a 09 20 20 bug-mode 1))..
c290: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
c2a0: 20 32 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 2 (map (lambda
c2b0: 28 72 6f 77 29 0a 09 09 09 09 20 20 20 20 28 63 (row)..... (c
c2c0: 6f 6e 63 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 onc (string-inte
c2d0: 72 73 70 65 72 73 65 0a 09 09 09 09 09 20 20 20 rsperse......
c2e0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 76 61 (map (lambda (va
c2f0: 72 76 61 6c 29 0a 09 09 09 09 09 09 20 20 28 73 rval)....... (s
c300: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
c310: 65 20 76 61 72 76 61 6c 20 22 3d 22 29 29 0a 09 e varval "="))..
c320: 09 09 09 09 09 72 6f 77 29 0a 09 09 09 09 09 20 .....row)......
c330: 20 20 22 20 22 29 0a 09 09 09 09 09 20 20 22 5c " ")...... "\
c340: 6e 22 29 29 0a 09 09 09 09 20 20 69 74 65 6d 73 n"))..... items
c350: 29 29 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 ))).. (for-each
c360: 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 79 .. (lambda (my
c370: 2d 69 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 -itemdat)..
c380: 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 (let* ((new-test
c390: 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 6e -record (let ((n
c3a0: 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 74 ewrec (make-test
c3b0: 73 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a 09 s:testqueue)))..
c3c0: 09 09 09 20 20 20 20 20 20 20 28 76 65 63 74 6f ... (vecto
c3d0: 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 r-copy! test-rec
c3e0: 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 ord newrec).....
c3f0: 20 20 20 20 20 20 20 6e 65 77 72 65 63 29 29 0a newrec)).
c400: 09 09 20 20 20 20 28 6d 79 2d 69 74 65 6d 2d 70 .. (my-item-p
c410: 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e ath (item-list->
c420: 70 61 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 path my-itemdat)
c430: 29 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 )).. (if (
c440: 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 tests:match test
c450: 2d 70 61 74 74 73 20 68 65 64 20 6d 79 2d 69 74 -patts hed my-it
c460: 65 6d 2d 70 61 74 68 20 72 65 71 75 69 72 65 64 em-path required
c470: 3a 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 : required-tests
c480: 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d ) ;; (patt-list-
c490: 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 match my-item-pa
c4a0: 74 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 th item-patts)
c4b0: 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c ;; yes,
c4c0: 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 we want to proc
c4d0: 65 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e ess this item, N
c4e0: 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 OTE: Should not
c4f0: 6e 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 need this check
c500: 68 65 72 65 21 0a 09 09 20 20 20 28 6c 65 74 20 here!... (let
c510: 28 28 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 72 ((newtestname (r
c520: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
c530: 73 74 2d 6e 61 6d 65 20 68 65 64 20 6d 79 2d 69 st-name hed my-i
c540: 74 65 6d 2d 70 61 74 68 29 29 29 20 20 20 20 3b tem-path))) ;
c550: 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 61 72 65 ; test names are
c560: 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 73 74 6e unique on testn
c570: 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 0a 09 09 ame/item-path...
c580: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
c590: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 queue-set-items!
c5a0: 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 new-test-re
c5b0: 63 6f 72 64 20 23 66 29 0a 09 09 20 20 20 20 20 cord #f)...
c5c0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
c5d0: 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 20 20 20 -set-itemdat!
c5e0: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
c5f0: 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 20 20 my-itemdat)...
c600: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
c610: 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 61 74 eue-set-item_pat
c620: 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f h! new-test-reco
c630: 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 rd my-item-path)
c640: 0a 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 ... (hash-ta
c650: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
c660: 63 6f 72 64 73 20 6e 65 77 74 65 73 74 6e 61 6d cords newtestnam
c670: 65 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 e new-test-recor
c680: 64 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 d)... (set!
c690: 74 61 6c 20 28 61 70 70 65 6e 64 20 74 61 6c 20 tal (append tal
c6a0: 28 6c 69 73 74 20 6e 65 77 74 65 73 74 6e 61 6d (list newtestnam
c6b0: 65 29 29 29 29 29 29 29 20 3b 3b 20 73 69 6e 63 e))))))) ;; sinc
c6c0: 65 20 74 68 65 73 65 20 61 72 65 20 69 74 65 6d e these are item
c6d0: 69 7a 65 64 20 63 72 65 61 74 65 20 6e 65 77 20 ized create new
c6e0: 74 65 73 74 20 6e 61 6d 65 73 20 74 65 73 74 6e test names testn
c6f0: 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 20 20 ame/itempath..
c700: 20 69 74 65 6d 73 29 0a 0a 09 20 20 3b 3b 20 28 items)... ;; (
c710: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
c720: 20 30 20 22 54 65 73 74 20 22 20 28 74 65 73 74 0 "Test " (test
c730: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
c740: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
c750: 63 6f 72 64 29 20 22 20 69 73 20 69 74 65 6d 69 cord) " is itemi
c760: 7a 65 64 20 62 75 74 20 68 61 73 20 6e 6f 20 69 zed but has no i
c770: 74 65 6d 73 22 29 0a 0a 09 20 20 3b 3b 20 41 74 tems")... ;; At
c780: 20 74 68 69 73 20 70 6f 69 6e 74 20 77 65 20 68 this point we h
c790: 61 76 65 20 70 6f 73 73 69 62 6c 79 20 61 64 64 ave possibly add
c7a0: 65 64 20 69 74 65 6d 73 20 74 6f 20 74 61 6c 20 ed items to tal
c7b0: 62 75 74 20 61 6c 6c 20 6d 75 73 74 20 62 65 20 but all must be
c7c0: 68 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 0a 09 handed off to ..
c7d0: 20 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 ;; INNER COND
c7e0: 6c 6f 67 69 63 2e 20 49 20 74 68 69 6e 6b 20 6c logic. I think l
c7f0: 6f 6f 70 20 77 69 74 68 6f 75 74 20 72 6f 74 61 oop without rota
c800: 74 69 6e 67 20 74 68 65 20 71 75 65 75 65 20 0a ting the queue .
c810: 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 68 65 64 20 . ;; (loop hed
c820: 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 29 29 tal reg reruns))
c830: 0a 09 20 20 3b 3b 20 28 6c 65 74 20 28 28 6e 65 .. ;; (let ((ne
c840: 77 74 61 6c 20 28 61 70 70 65 6e 64 20 74 61 6c wtal (append tal
c850: 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 20 20 (list hed))))
c860: 3b 3b 20 57 65 20 73 68 6f 75 6c 64 20 64 69 73 ;; We should dis
c870: 63 61 72 64 20 68 65 64 20 61 73 20 69 74 20 68 card hed as it h
c880: 61 73 20 62 65 65 6e 20 65 78 70 61 6e 64 65 64 as been expanded
c890: 20 69 6e 74 6f 20 69 74 27 73 20 69 74 65 6d 73 into it's items
c8a0: 3f 20 59 65 73 2c 20 62 75 74 20 6f 6e 6c 79 20 ? Yes, but only
c8b0: 69 66 20 74 68 69 73 20 2a 69 73 2a 20 61 6e 20 if this *is* an
c8c0: 69 74 65 6d 69 7a 65 64 20 74 65 73 74 0a 09 20 itemized test..
c8d0: 20 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e ;; (loop (car n
c8e0: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
c8f0: 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 0a 09 l) reg reruns)..
c900: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
c910: 29 0a 09 20 20 20 20 20 20 23 66 0a 09 20 20 20 ).. #f..
c920: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
c930: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 20 l)(cdr tal) reg
c940: 72 65 72 75 6e 73 29 29 29 0a 09 20 20 20 20 0a reruns))).. .
c950: 09 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 69 73 . ;; if items is
c960: 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e 65 65 a proc then nee
c970: 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 3a 67 d to run items:g
c980: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
c990: 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 6c 69 nfig, get the li
c9a0: 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 3b st and loop .. ;
c9b0: 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e 6c 79 20 ; - but only
c9c0: 64 6f 20 74 68 61 74 20 69 66 20 72 65 73 6f 75 do that if resou
c9d0: 72 63 65 73 20 65 78 69 73 74 20 74 6f 20 6b 69 rces exist to ki
c9e0: 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f 62 0a 09 ck off the job..
c9f0: 20 3b 3b 20 45 58 50 41 4e 44 20 49 54 45 4d 53 ;; EXPAND ITEMS
ca00: 0a 09 20 28 28 6f 72 20 28 70 72 6f 63 65 64 75 .. ((or (procedu
ca10: 72 65 3f 20 69 74 65 6d 73 29 28 65 71 3f 20 69 re? items)(eq? i
ca20: 74 65 6d 73 20 27 68 61 76 65 2d 70 72 6f 63 65 tems 'have-proce
ca30: 64 75 72 65 29 29 0a 09 20 20 28 6c 65 74 20 28 dure)).. (let (
ca40: 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 (can-run-more
ca50: 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d (runs:can-run-m
ca60: 6f 72 65 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 ore-tests run-id
ca70: 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f jobgroup max-co
ca80: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 ncurrent-jobs)))
ca90: 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
caa0: 6c 69 73 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f list? can-run-mo
cab0: 72 65 29 0a 09 09 20 20 20 20 20 28 63 61 72 20 re)... (car
cac0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 can-run-more))..
cad0: 09 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 .(let ((loop-lis
cae0: 74 20 28 72 75 6e 73 3a 65 78 70 61 6e 64 2d 69 t (runs:expand-i
caf0: 74 65 6d 73 20 68 65 64 20 74 61 6c 20 72 65 67 tems hed tal reg
cb00: 20 72 65 72 75 6e 73 20 72 65 67 66 75 6c 6c 20 reruns regfull
cb10: 6e 65 77 74 61 6c 20 6a 6f 62 67 72 6f 75 70 20 newtal jobgroup
cb20: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
cb30: 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 74 6f obs run-id waito
cb40: 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 ns item-path tes
cb50: 74 6d 6f 64 65 20 74 65 73 74 2d 72 65 63 6f 72 tmode test-recor
cb60: 64 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 69 d can-run-more i
cb70: 74 65 6d 73 20 72 75 6e 6e 61 6d 65 20 74 63 6f tems runname tco
cb80: 6e 66 69 67 20 72 65 67 6c 65 6e 20 74 65 73 74 nfig reglen test
cb90: 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 2d 72 -registry test-r
cba0: 65 63 6f 72 64 73 20 69 74 65 6d 6d 61 70 29 29 ecords itemmap))
cbb0: 29 0a 09 09 20 20 28 69 66 20 6c 6f 6f 70 2d 6c )... (if loop-l
cbc0: 69 73 74 0a 09 09 20 20 20 20 20 20 28 61 70 70 ist... (app
cbd0: 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c 69 73 ly loop loop-lis
cbe0: 74 29 29 29 0a 09 09 3b 3b 20 69 66 20 63 61 6e t)))...;; if can
cbf0: 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 't run more just
cc00: 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 20 loop with next
cc10: 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a 09 09 possible test...
cc20: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
cc30: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
cc40: 65 67 20 72 65 72 75 6e 73 29 29 29 29 0a 09 20 eg reruns))))..
cc50: 20 20 20 0a 09 20 3b 3b 20 74 68 69 73 20 63 61 .. ;; this ca
cc60: 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 se should not ha
cc70: 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 ppen, added to h
cc80: 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 62 75 elp catch any bu
cc90: 67 73 0a 09 20 28 28 61 6e 64 20 28 6c 69 73 74 gs.. ((and (list
cca0: 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 64 61 74 ? items) itemdat
ccb0: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
ccc0: 74 20 30 20 22 45 52 52 4f 52 3a 20 53 68 6f 75 t 0 "ERROR: Shou
ccd0: 6c 64 20 6e 6f 74 20 68 61 76 65 20 61 20 6c 69 ld not have a li
cce0: 73 74 20 6f 66 20 69 74 65 6d 73 20 69 6e 20 61 st of items in a
ccf0: 20 74 65 73 74 20 61 6e 64 20 74 68 65 20 69 74 test and the it
cd00: 65 6d 73 70 61 74 68 20 73 65 74 20 2d 20 70 6c emspath set - pl
cd10: 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 ease report this
cd20: 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 0a ").. (exit 1)).
cd30: 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 . ((not (null? r
cd40: 65 72 75 6e 73 29 29 0a 09 20 20 28 6c 65 74 2a eruns)).. (let*
cd50: 20 28 28 6e 65 77 6c 73 74 20 28 74 65 73 74 73 ((newlst (tests
cd60: 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e :filter-non-runn
cd70: 61 62 6c 65 20 72 75 6e 2d 69 64 20 74 61 6c 20 able run-id tal
cd80: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 20 3b test-records)) ;
cd90: 3b 20 69 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c ; i.e. not FAIL,
cda0: 20 57 41 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c WAIVED, INCOMPL
cdb0: 45 54 45 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 ETE, PASS, KILLE
cdc0: 44 2c 0a 09 09 20 28 6a 75 6e 6b 65 64 20 28 6c D,... (junked (l
cdd0: 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 20 65 set-difference e
cde0: 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 74 qual? tal newlst
cdf0: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
ce00: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 66 75 print-info 4 "fu
ce10: 6c 6c 20 64 72 6f 70 20 74 68 72 6f 75 67 68 2c ll drop through,
ce20: 20 69 66 20 72 65 72 75 6e 73 20 69 73 20 6c 65 if reruns is le
ce30: 73 73 20 74 68 61 6e 20 31 30 30 20 77 65 20 77 ss than 100 we w
ce40: 69 6c 6c 20 66 6f 72 63 65 20 72 65 74 72 79 20 ill force retry
ce50: 74 68 65 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 them, reruns=" r
ce60: 65 72 75 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 eruns ", tal=" t
ce70: 61 6c 29 0a 09 20 20 20 20 28 69 66 20 28 3c 20 al).. (if (<
ce80: 6e 75 6d 2d 72 65 74 72 69 65 73 20 6d 61 78 2d num-retries max-
ce90: 72 65 74 72 69 65 73 29 0a 09 09 28 73 65 74 21 retries)...(set!
cea0: 20 6e 65 77 6c 73 74 20 28 61 70 70 65 6e 64 20 newlst (append
ceb0: 72 65 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 reruns newlst)))
cec0: 0a 09 20 20 20 20 28 73 65 74 21 20 6e 75 6d 2d .. (set! num-
ced0: 72 65 74 72 69 65 73 20 28 2b 20 6e 75 6d 2d 72 retries (+ num-r
cee0: 65 74 72 69 65 73 20 31 29 29 0a 09 20 20 20 20 etries 1))..
cef0: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
cf00: 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 ! (+ 1 *global-d
cf10: 65 6c 74 61 2a 29 29 0a 09 20 20 20 20 28 69 66 elta*)).. (if
cf20: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 (not (null? new
cf30: 6c 73 74 29 29 0a 09 09 3b 3b 20 73 69 6e 63 65 lst))...;; since
cf40: 20 72 65 72 75 6e 73 20 68 61 76 65 20 62 65 65 reruns have bee
cf50: 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 6f 20 6e n tacked on to n
cf60: 65 77 6c 73 74 20 63 72 65 61 74 65 20 6e 65 77 ewlst create new
cf70: 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 6a 75 6e reruns from jun
cf80: 6b 65 64 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 ked...(loop (car
cf90: 20 6e 65 77 6c 73 74 29 28 63 64 72 20 6e 65 77 newlst)(cdr new
cfa0: 6c 73 74 29 20 72 65 67 20 28 64 65 6c 65 74 65 lst) reg (delete
cfb0: 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 6e 6b -duplicates junk
cfc0: 65 64 29 29 29 29 29 0a 09 20 28 28 6e 6f 74 20 ed))))).. ((not
cfd0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 (null? tal))..
cfe0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
cff0: 6f 20 34 20 22 49 27 6d 20 70 72 65 74 74 79 20 o 4 "I'm pretty
d000: 73 75 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 sure I shouldn't
d010: 20 67 65 74 20 68 65 72 65 2e 22 29 29 0a 09 20 get here."))..
d020: 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 ((not (null? reg
d030: 29 29 20 3b 3b 20 63 6f 75 6c 64 20 77 65 20 67 )) ;; could we g
d040: 65 74 20 68 65 72 65 20 77 69 74 68 20 6c 65 66 et here with lef
d050: 74 6f 76 65 72 73 3f 0a 09 20 20 28 64 65 62 75 tovers?.. (debu
d060: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
d070: 48 61 76 65 20 6c 65 66 74 6f 76 65 72 73 21 22 Have leftovers!"
d080: 29 0a 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ).. (loop (car
d090: 72 65 67 29 28 63 64 72 20 72 65 67 29 20 27 28 reg)(cdr reg) '(
d0a0: 29 20 72 65 72 75 6e 73 29 29 0a 09 20 28 65 6c ) reruns)).. (el
d0b0: 73 65 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 se.. (debug:pri
d0c0: 6e 74 2d 69 6e 66 6f 20 34 20 22 45 78 69 74 69 nt-info 4 "Exiti
d0d0: 6e 67 20 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c ng loop with...\
d0e0: 6e 20 20 68 65 64 3d 22 20 68 65 64 20 22 5c 6e n hed=" hed "\n
d0f0: 20 20 74 61 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 tal=" tal "\n
d100: 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 reruns=" reruns
d110: 29 29 0a 09 20 29 29 29 0a 20 20 20 20 3b 3b 20 )).. ))). ;;
d120: 6e 6f 77 20 2a 69 66 2a 20 2d 72 75 6e 2d 77 61 now *if* -run-wa
d130: 69 74 20 77 65 20 77 61 69 74 20 66 6f 72 20 61 it we wait for a
d140: 6c 6c 20 74 65 73 74 73 20 74 6f 20 62 65 20 64 ll tests to be d
d150: 6f 6e 65 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 77 one. ;; Now w
d160: 61 69 74 20 66 6f 72 20 61 6e 79 20 52 55 4e 4e ait for any RUNN
d170: 49 4e 47 20 74 65 73 74 73 20 74 6f 20 63 6f 6d ING tests to com
d180: 70 6c 65 74 65 20 28 69 66 20 69 6e 20 72 75 6e plete (if in run
d190: 2d 77 61 69 74 20 6d 6f 64 65 29 0a 20 20 20 20 -wait mode).
d1a0: 28 6c 65 74 20 77 61 69 74 2d 6c 6f 6f 70 20 28 (let wait-loop (
d1b0: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 (num-running
d1c0: 20 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 (rmt:get-count
d1d0: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
d1e0: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
d1f0: 29 29 0a 09 09 20 20 20 20 28 70 72 65 76 2d 6e ))... (prev-n
d200: 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 29 0a 20 um-running 0)).
d210: 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 ;; (debug:p
d220: 72 69 6e 74 20 30 20 22 6e 75 6d 2d 72 75 6e 6e rint 0 "num-runn
d230: 69 6e 67 3d 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ing=" num-runnin
d240: 67 20 22 2c 20 70 72 65 76 2d 6e 75 6d 2d 72 75 g ", prev-num-ru
d250: 6e 6e 69 6e 67 3d 22 20 70 72 65 76 2d 6e 75 6d nning=" prev-num
d260: 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 20 20 -running).
d270: 28 69 66 20 28 61 6e 64 20 28 6f 72 20 28 61 72 (if (and (or (ar
d280: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
d290: 2d 77 61 69 74 22 29 0a 09 09 20 20 20 28 65 71 -wait")... (eq
d2a0: 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ual? (configf:lo
d2b0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
d2c0: 20 22 73 65 74 75 70 22 20 22 72 75 6e 2d 77 61 "setup" "run-wa
d2d0: 69 74 22 29 20 22 79 65 73 22 29 29 0a 09 20 20 it") "yes"))..
d2e0: 20 20 20 20 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e (> num-runn
d2f0: 69 6e 67 20 30 29 29 0a 09 20 20 28 62 65 67 69 ing 0)).. (begi
d300: 6e 0a 09 20 20 20 20 3b 3b 20 48 65 72 65 20 77 n.. ;; Here w
d310: 65 20 6d 61 72 6b 20 61 6e 79 20 6f 6c 64 20 64 e mark any old d
d320: 65 66 75 6e 63 74 20 74 65 73 74 73 20 61 73 20 efunct tests as
d330: 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 44 6f 20 74 incomplete. Do t
d340: 68 69 73 20 65 76 65 72 79 20 66 69 66 74 65 65 his every fiftee
d350: 6e 20 6d 69 6e 75 74 65 73 0a 09 20 20 20 20 3b n minutes.. ;
d360: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
d370: 20 22 47 6f 74 20 68 65 72 65 20 65 68 21 20 6e "Got here eh! n
d380: 75 6d 2d 72 75 6e 6e 69 6e 67 3d 22 20 6e 75 6d um-running=" num
d390: 2d 72 75 6e 6e 69 6e 67 20 22 20 28 3e 20 6e 75 -running " (> nu
d3a0: 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 20 22 20 28 m-running 0) " (
d3b0: 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 > num-running 0)
d3c0: 29 0a 09 20 20 20 20 28 69 66 20 28 3e 20 28 63 ).. (if (> (c
d3d0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
d3e0: 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f + last-time-inco
d3f0: 6d 70 6c 65 74 65 20 39 30 30 29 29 0a 09 09 28 mplete 900))...(
d400: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
d410: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4d :print-info 0 "M
d420: 61 72 6b 69 6e 67 20 73 74 75 63 6b 20 74 65 73 arking stuck tes
d430: 74 73 20 61 73 20 49 4e 43 4f 4d 50 4c 45 54 45 ts as INCOMPLETE
d440: 20 77 68 69 6c 65 20 77 61 69 74 69 6e 67 20 66 while waiting f
d450: 6f 72 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 or run " run-id
d460: 22 2e 20 52 75 6e 6e 69 6e 67 20 61 73 20 70 69 ". Running as pi
d470: 64 20 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f d " (current-pro
d480: 63 65 73 73 2d 69 64 29 20 22 20 6f 6e 20 22 20 cess-id) " on "
d490: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
d4a0: 0a 09 09 20 20 28 73 65 74 21 20 6c 61 73 74 2d ... (set! last-
d4b0: 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 time-incomplete
d4c0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
d4d0: 29 29 0a 09 09 20 20 28 72 6d 74 3a 66 69 6e 64 ))... (rmt:find
d4e0: 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 -and-mark-incomp
d4f0: 6c 65 74 65 20 72 75 6e 2d 69 64 20 23 66 29 29 lete run-id #f))
d500: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
d510: 28 65 71 3f 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (eq? num-running
d520: 20 70 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e prev-num-runnin
d530: 67 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 g))...(debug:pri
d540: 6e 74 2d 69 6e 66 6f 20 30 20 22 72 75 6e 2d 77 nt-info 0 "run-w
d550: 61 69 74 20 73 70 65 63 69 66 69 65 64 2c 20 77 ait specified, w
d560: 61 69 74 69 6e 67 20 6f 6e 20 22 20 6e 75 6d 2d aiting on " num-
d570: 72 75 6e 6e 69 6e 67 20 22 20 74 65 73 74 73 20 running " tests
d580: 69 6e 20 52 55 4e 4e 49 4e 47 2c 20 52 45 4d 4f in RUNNING, REMO
d590: 54 45 48 4f 53 54 53 54 41 52 54 20 6f 72 20 4c TEHOSTSTART or L
d5a0: 41 55 4e 43 48 45 44 20 73 74 61 74 65 20 61 74 AUNCHED state at
d5b0: 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 " (time->string
d5c0: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
d5d0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
d5e0: 65 63 6f 6e 64 73 29 29 29 29 29 0a 09 20 20 20 econds)))))..
d5f0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
d600: 31 35 29 0a 09 20 20 20 20 3b 3b 20 28 77 61 69 15).. ;; (wai
d610: 74 2d 6c 6f 6f 70 20 28 72 6d 74 3a 67 65 74 2d t-loop (rmt:get-
d620: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
d630: 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 ing-for-run-id r
d640: 75 6e 2d 69 64 29 20 6e 75 6d 2d 72 75 6e 6e 69 un-id) num-runni
d650: 6e 67 29 29 29 29 0a 09 20 20 20 20 28 77 61 69 ng)))).. (wai
d660: 74 2d 6c 6f 6f 70 20 28 72 6d 74 3a 67 65 74 2d t-loop (rmt:get-
d670: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
d680: 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 ing-for-run-id r
d690: 75 6e 2d 69 64 29 20 6e 75 6d 2d 72 75 6e 6e 69 un-id) num-runni
d6a0: 6e 67 29 29 29 29 0a 20 20 20 20 3b 3b 20 4c 45 ng)))). ;; LE
d6b0: 54 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 T* ((test-record
d6c0: 0a 20 20 20 20 3b 3b 20 77 65 20 67 65 74 20 68 . ;; we get h
d6d0: 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 ere on "drop thr
d6e0: 6f 75 67 68 22 2e 20 41 6c 6c 20 64 6f 6e 65 21 ough". All done!
d6f0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
d700: 74 2d 69 6e 66 6f 20 31 20 22 41 6c 6c 20 74 65 t-info 1 "All te
d710: 73 74 73 20 6c 61 75 6e 63 68 65 64 22 29 29 29 sts launched")))
d720: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
d730: 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 calc-fails prere
d740: 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 qs-not-met). (f
d750: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 ilter (lambda (t
d760: 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 28 est).. (and (
d770: 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b 3b vector? test) ;;
d780: 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 65 not (string? te
d790: 73 74 29 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 st))... (equal?
d7a0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
d7b0: 74 65 20 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 te test) "COMPLE
d7c0: 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 20 28 6d TED")... (not (m
d7d0: 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
d7e0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 29 0a et-status test).
d7f0: 09 09 09 20 20 20 20 20 20 27 28 22 50 41 53 53 ... '("PASS
d800: 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 " "WARN" "CHECK"
d810: 20 22 57 41 49 56 45 44 22 20 22 53 4b 49 50 22 "WAIVED" "SKIP"
d820: 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 73 ))))).. prereqs
d830: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 -not-met))..(def
d840: 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 70 ine (runs:calc-p
d850: 72 65 72 65 71 2d 66 61 69 6c 20 70 72 65 72 65 rereq-fail prere
d860: 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 qs-not-met). (f
d870: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 ilter (lambda (t
d880: 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 28 est).. (and (
d890: 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b 3b vector? test) ;;
d8a0: 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 65 not (string? te
d8b0: 73 74 29 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 st))... (equal?
d8c0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
d8d0: 74 65 20 74 65 73 74 29 20 22 4e 4f 54 5f 53 54 te test) "NOT_ST
d8e0: 41 52 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 20 ARTED")... (not
d8f0: 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
d900: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 -get-status test
d910: 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 6e 2f ).... '("n/
d920: 61 22 20 22 4b 45 45 50 5f 54 52 59 49 4e 47 22 a" "KEEP_TRYING"
d930: 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 73 ))))).. prereqs
d940: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 -not-met))..(def
d950: 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e ine (runs:calc-n
d960: 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 ot-completed pre
d970: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 reqs-not-met).
d980: 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 6d 62 (filter. (lamb
d990: 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 20 da (t). (or
d9a0: 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 (not (vector? t)
d9b0: 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f ).. (not (equal?
d9c0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 62 "COMPLETED" (db
d9d0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
d9e0: 74 29 29 29 29 29 0a 20 20 20 70 72 65 72 65 71 t))))). prereq
d9f0: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 s-not-met))..(de
da00: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
da10: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
da20: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
da30: 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 6d (filter. (lam
da40: 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 bda (t). (or
da50: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 (not (vector? t
da60: 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 6c )).. (not (equal
da70: 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 ? "COMPLETED" (d
da80: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
da90: 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 72 65 t))))). prere
daa0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 qs-not-met))..(d
dab0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
dac0: 2d 72 75 6e 6e 61 62 6c 65 20 70 72 65 72 65 71 -runnable prereq
dad0: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 s-not-met). (fi
dae0: 6c 74 65 72 20 0a 20 20 20 28 6c 61 6d 62 64 61 lter . (lambda
daf0: 20 28 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e (t). (or (n
db00: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
db10: 09 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 22 . (and (equal? "
db20: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 28 64 62 NOT_STARTED" (db
db30: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
db40: 74 29 29 0a 09 20 20 20 20 20 20 28 6d 65 6d 62 t)).. (memb
db50: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
db60: 73 74 61 74 75 73 20 74 29 0a 09 09 09 20 20 20 status t)....
db70: 20 20 20 27 28 22 6e 2f 61 22 20 22 4b 45 45 50 '("n/a" "KEEP
db80: 5f 54 52 59 49 4e 47 22 29 29 29 29 29 0a 20 20 _TRYING"))))).
db90: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
dba0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
dbb0: 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 s:pretty-string
dbc0: 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d lst). (map (lam
dbd0: 62 64 61 20 28 74 29 0a 09 20 28 69 66 20 28 6e bda (t).. (if (n
dbe0: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
dbf0: 09 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 . (conc t)..
dc00: 20 20 20 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 (conc (db:t
dc10: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
dc20: 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 t) ":" (db:test
dc30: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
dc40: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
dc50: 74 61 74 75 73 20 74 29 29 29 29 0a 20 20 20 20 tatus t)))).
dc60: 20 20 20 6c 73 74 29 29 0a 0a 28 64 65 66 69 6e lst))..(defin
dc70: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
dc80: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
dc90: 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 name itempath).
dca0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 (if (equal? ite
dcb0: 6d 70 61 74 68 20 22 22 29 20 74 65 73 74 6e 61 mpath "") testna
dcc0: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
dcd0: 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 29 29 e "/" itempath))
dce0: 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 )..;; parent-tes
dcf0: 74 20 69 73 20 74 68 65 72 65 20 61 73 20 61 20 t is there as a
dd00: 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 placeholder for
dd10: 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 when parent-test
dd20: 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 20 s can be run as
dd30: 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 65 a setup step.(de
dd40: 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 72 fine (run:test r
dd50: 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b un-id run-info k
dd60: 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 eyvals runname t
dd70: 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 est-record flags
dd80: 20 70 61 72 65 6e 74 2d 74 65 73 74 20 74 65 73 parent-test tes
dd90: 74 2d 72 65 67 69 73 74 72 79 20 61 6c 6c 2d 74 t-registry all-t
dda0: 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 ests-registry).
ddb0: 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 61 ;; All these va
ddc0: 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 66 65 rs might be refe
ddd0: 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 74 65 renced by the te
dde0: 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 stconfig file re
ddf0: 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 ader. (let* ((t
de00: 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 est-name (tes
de10: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
de20: 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 -testname test
de30: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 -record)).. (tes
de40: 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 t-waitons (tests
de50: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
de60: 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 aitons test-r
de70: 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d ecord)).. (test-
de80: 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 3a 74 conf (tests:t
de90: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
dea0: 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 tconfig test-rec
deb0: 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 61 74 ord)).. (itemdat
dec0: 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 (tests:tes
ded0: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 tqueue-get-itemd
dee0: 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 at test-recor
def0: 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 68 d)).. (test-path
df00: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
df10: 72 65 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 ref all-tests-re
df20: 67 69 73 74 72 79 20 74 65 73 74 2d 6e 61 6d 65 gistry test-name
df30: 29 29 20 3b 3b 20 28 63 6f 6e 63 20 2a 74 6f 70 )) ;; (conc *top
df40: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
df50: 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 test-name)) ;; c
df60: 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a 67 ould use tests:g
df70: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
df80: 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 re ..... (force
df90: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
dfa0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
dfb0: 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 66 lags "-force" #f
dfc0: 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 20 )).. (rerun
dfd0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
dfe0: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
dff0: 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a 09 "-rerun" #f))..
e000: 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 28 (keepgoing (
e010: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
e020: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b efault flags "-k
e030: 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 eepgoing" #f))..
e040: 20 28 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d (incomplete-tim
e050: 65 6f 75 74 20 28 73 74 72 69 6e 67 2d 3e 6e 75 eout (string->nu
e060: 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 mber (or (config
e070: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
e080: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 69 6e dat* "setup" "in
e090: 63 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 6f 75 74 complete-timeout
e0a0: 22 29 20 22 78 22 29 29 29 0a 09 20 28 69 74 65 ") "x"))).. (ite
e0b0: 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 m-path "")..
e0c0: 20 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 (db #
e0d0: 66 29 0a 09 20 28 66 75 6c 6c 2d 74 65 73 74 2d f).. (full-test-
e0e0: 6e 61 6d 65 20 23 66 29 29 0a 0a 20 20 20 20 3b name #f)).. ;
e0f0: 3b 20 73 65 74 74 69 6e 67 20 69 74 65 6d 64 61 ; setting itemda
e100: 74 20 74 6f 20 61 20 6c 69 73 74 20 69 66 20 69 t to a list if i
e110: 74 20 69 73 20 23 66 0a 20 20 20 20 28 69 66 20 t is #f. (if
e120: 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 73 65 (not itemdat)(se
e130: 74 21 20 69 74 65 6d 64 61 74 20 27 28 29 29 29 t! itemdat '()))
e140: 0a 20 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d . (set! item-
e150: 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d path (item-list-
e160: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
e170: 20 20 20 20 28 73 65 74 21 20 66 75 6c 6c 2d 74 (set! full-t
e180: 65 73 74 2d 6e 61 6d 65 20 28 72 75 6e 73 3a 6d est-name (runs:m
e190: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
e1a0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
e1b0: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 64 65 m-path)). (de
e1c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
e1d0: 0a 09 09 20 20 20 20 20 20 22 5c 6e 54 45 53 54 ... "\nTEST
e1e0: 4e 41 4d 45 3a 20 22 20 66 75 6c 6c 2d 74 65 73 NAME: " full-tes
e1f0: 74 2d 6e 61 6d 65 20 0a 09 09 20 20 20 20 20 20 t-name ...
e200: 22 5c 6e 20 20 20 74 65 73 74 2d 63 6f 6e 66 69 "\n test-confi
e210: 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 g: " (hash-table
e220: 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e ->alist test-con
e230: 66 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 20 f)... "\n
e240: 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d itemdat: " item
e250: 64 61 74 0a 09 09 20 20 20 20 20 20 29 0a 20 20 dat... ).
e260: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
e270: 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "Attempting to
e280: 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 66 75 launch test " fu
e290: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 ll-test-name).
e2a0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE
e2b0: 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 ST_NAME" test-na
e2c0: 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 me) ;; . (set
e2d0: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
e2e0: 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 " item-path).
e2f0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
e300: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
e310: 29 0a 20 20 20 20 28 72 75 6e 73 3a 73 65 74 2d ). (runs:set-
e320: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
e330: 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e 61 s run-id inrunna
e340: 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 me: runname) ;;
e350: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
e360: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
e370: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 hing process.
e380: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
e390: 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 ry *toppath*)..
e3a0: 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 ;; Here is wh
e3b0: 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ere the test_met
e3c0: 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 a table is best
e3d0: 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 updated. ;; Y
e3e0: 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 es, another use
e3f0: 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 of a global for
e400: 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 caching. Need a
e410: 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 better way?.
e420: 3b 3b 0a 20 20 20 20 3b 3b 20 54 68 65 72 65 20 ;;. ;; There
e430: 69 73 20 6e 6f 77 20 61 20 73 69 6e 67 6c 65 20 is now a single
e440: 63 61 6c 6c 20 74 6f 20 72 75 6e 73 3a 75 70 64 call to runs:upd
e450: 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 ate-all-test_met
e460: 61 20 61 6e 64 20 74 68 69 73 20 0a 20 20 20 20 a and this .
e470: 3b 3b 20 70 65 72 2d 74 65 73 74 20 63 61 6c 6c ;; per-test call
e480: 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 2e 20 is not needed.
e490: 47 69 76 65 6e 20 74 68 65 20 64 65 6c 69 63 61 Given the delica
e4a0: 63 79 20 6f 66 20 74 68 65 20 6d 6f 76 65 20 74 cy of the move t
e4b0: 6f 20 0a 20 20 20 20 3b 3b 20 76 31 2e 35 35 20 o . ;; v1.55
e4c0: 74 68 69 73 20 63 6f 64 65 20 69 73 20 62 65 69 this code is bei
e4d0: 6e 67 20 6c 65 66 74 20 69 6e 20 70 6c 61 63 65 ng left in place
e4e0: 20 66 6f 72 20 74 68 65 20 74 69 6d 65 20 62 65 for the time be
e4f0: 69 6e 67 2e 0a 20 20 20 20 3b 3b 0a 20 20 20 20 ing.. ;;.
e500: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
e510: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
e520: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
e530: 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 ted* test-name #
e540: 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 f)). (beg
e550: 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 in.. (hash-tab
e560: 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 le-set! *test-me
e570: 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 ta-updated* test
e580: 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 -name #t).
e590: 20 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 (runs:updat
e5a0: 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 e-test_meta test
e5b0: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
e5c0: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 )). . ;; i
e5d0: 74 65 6d 64 61 74 20 3d 3e 20 28 28 72 69 70 65 temdat => ((ripe
e5e0: 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 ness "overripe")
e5f0: 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 (temperature "c
e600: 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 ool") (season "s
e610: 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 ummer")). (le
e620: 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 t* ((new-test-pa
e630: 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 th (string-inter
e640: 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 sperse (cons tes
e650: 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 t-path (map cadr
e660: 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 itemdat)) "/"))
e670: 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
e680: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
e690: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
e6a0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
e6b0: 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 20 ).. (testdat
e6c0: 20 20 20 20 20 28 69 66 20 74 65 73 74 2d 69 64 (if test-id
e6d0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
e6e0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
e6f0: 20 74 65 73 74 2d 69 64 29 20 23 66 29 29 29 0a test-id) #f))).
e700: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 (if (not t
e710: 65 73 74 64 61 74 29 0a 09 20 20 28 6c 65 74 20 estdat).. (let
e720: 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b 20 loop ().. ;;
e730: 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 ensure that the
e740: 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 6f path exists befo
e750: 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 re registering t
e760: 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 he test.. ;;
e770: 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f NOPE: Cannot! Do
e780: 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 n't know yet whi
e790: 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c ch disk area wil
e7a0: 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e l be assigned...
e7b0: 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 ... ;; (syste
e7c0: 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d m (conc "mkdir -
e7d0: 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 p " new-test-pat
e7e0: 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 h)).. ;;..
e7f0: 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; (open-run-cl
e800: 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 ose tests:regist
e810: 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 er-test db run-i
e820: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
e830: 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 -path).. ;;..
e840: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 ;; NB// for
e850: 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 the above line.
e860: 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 I want the test
e870: 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 64 to be registered
e880: 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 long before thi
e890: 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 s routine gets c
e8a0: 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 alled!.. ;;..
e8b0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 (if (not tes
e8c0: 74 2d 69 64 29 28 73 65 74 21 20 74 65 73 74 2d t-id)(set! test-
e8d0: 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 id (rmt:get-test
e8e0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
e8f0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
e900: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
e910: 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 69 test-id)...(begi
e920: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
e930: 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 74 nt 2 "WARN: Test
e940: 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 64 not pre-created
e950: 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 ? test-name=" te
e960: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
e970: 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 path=" item-path
e980: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
e990: 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a 67 65 -id)... (rmt:ge
e9a0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 neral-call 'regi
e9b0: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
e9c0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
e9d0: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 e item-path)...
e9e0: 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 (set! test-id (
e9f0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 rmt:get-test-id
ea00: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
ea10: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 item-path))))..
ea20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
ea30: 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 64 -info 4 "test-id
ea40: 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 72 75 =" test-id ", ru
ea50: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c n-id=" run-id ",
ea60: 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 test-name=" tes
ea70: 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 t-name ", item-p
ea80: 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 74 ath=\"" item-pat
ea90: 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 73 65 h "\"").. (se
eaa0: 74 21 20 74 65 73 74 64 61 74 20 28 72 6d 74 3a t! testdat (rmt:
eab0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
eac0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
ead0: 69 64 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e id)).. (if (n
eae0: 6f 74 20 74 65 73 74 64 61 74 29 0a 09 09 28 62 ot testdat)...(b
eaf0: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
eb00: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 41 print-info 0 "WA
eb10: 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 69 73 RNING: server is
eb20: 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 74 72 79 overloaded, try
eb30: 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 6f 6e 65 ing again in one
eb40: 20 73 65 63 6f 6e 64 22 29 0a 09 09 20 20 28 74 second")... (t
eb50: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
eb60: 09 09 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a 20 .. (loop))))).
eb70: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
eb80: 73 74 64 61 74 29 20 3b 3b 20 73 68 6f 75 6c 64 stdat) ;; should
eb90: 20 4e 4f 54 20 68 61 70 70 65 6e 0a 09 20 20 28 NOT happen.. (
eba0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
ebb0: 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 RROR: failed to
ebc0: 67 65 74 20 74 65 73 74 20 72 65 63 6f 72 64 20 get test record
ebd0: 66 6f 72 20 74 65 73 74 2d 69 64 20 22 20 74 65 for test-id " te
ebe0: 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 73 st-id)). (s
ebf0: 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a et! test-id (db:
ec00: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
ec10: 64 61 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 dat)). (if
ec20: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
ec30: 73 74 2d 70 61 74 68 29 0a 09 20 20 28 63 68 61 st-path).. (cha
ec40: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 nge-directory te
ec50: 73 74 2d 70 61 74 68 29 0a 09 20 20 28 62 65 67 st-path).. (beg
ec60: 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 in.. (debug:p
ec70: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 65 73 rint "ERROR: tes
ec80: 74 20 72 75 6e 20 70 61 74 68 20 6e 6f 74 20 63 t run path not c
ec90: 72 65 61 74 65 64 20 62 65 66 6f 72 65 20 61 74 reated before at
eca0: 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 75 6e 20 tempting to run
ecb0: 74 68 65 20 74 65 73 74 2e 20 50 65 72 68 61 70 the test. Perhap
ecc0: 73 20 79 6f 75 20 61 72 65 20 72 75 6e 6e 69 6e s you are runnin
ecd0: 67 20 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 20 61 g -remove-runs a
ece0: 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 3f t the same time?
ecf0: 22 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 2d ").. (change-
ed00: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
ed10: 74 68 2a 29 29 29 0a 20 20 20 20 20 20 28 63 61 th*))). (ca
ed20: 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 se (if force ;;
ed30: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
ed40: 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 force")...'NOT_S
ed50: 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 TARTED...(if tes
ed60: 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 tdat... (stri
ed70: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 ng->symbol (test
ed80: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
ed90: 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c at))... 'fail
eda0: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 ed-to-insert))..
edb0: 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 ((failed-to-inse
edc0: 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 rt).. (debug:pri
edd0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
ede0: 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 led to insert th
edf0: 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 e record into th
ee00: 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 e db"))..((NOT_S
ee10: 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 TARTED COMPLETED
ee20: 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 DELETED).. (let
ee30: 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a ((runflag #f)).
ee40: 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b . (cond.. ;
ee50: 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f ; -force, run no
ee60: 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 matter what..
ee70: 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 (force (set! r
ee80: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
ee90: 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c ;; NOT_STARTED,
eea0: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
eeb0: 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 hat.. ((membe
eec0: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
eed0: 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 45 e testdat) '("DE
eee0: 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 LETED" "NOT_STAR
eef0: 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e 66 TED"))(set! runf
ef00: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
ef10: 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 not -rerun and
ef20: 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 PASS, WARN or CH
ef30: 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 ECK, do no run..
ef40: 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e ((and (or (n
ef50: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 ot rerun)...
ef60: 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 keepgoing)...
ef70: 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 ;; Require to f
ef80: 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 orce re-run for
ef90: 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e COMPLETED or *an
efa0: 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 ything* + PASS,W
efb0: 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 ARN or CHECK...
efc0: 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 (or (member (te
efd0: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
efe0: 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 stdat) '("PASS"
eff0: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 "WARN" "CHECK" "
f000: 53 4b 49 50 22 20 22 57 41 49 56 45 44 22 29 29 SKIP" "WAIVED"))
f010: 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
f020: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
f030: 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 4f testdat) '("CO
f040: 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 MPLETED")))) ..
f050: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f060: 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 -info 2 "running
f070: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
f080: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 e "/" item-path
f090: 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 20 " suppressed as
f0a0: 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 it is " (test:ge
f0b0: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
f0c0: 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 " and " (test:g
f0d0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
f0e0: 74 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d t)).. (hash-
f0f0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
f100: 72 65 67 69 73 74 72 79 20 66 75 6c 6c 2d 74 65 registry full-te
f110: 73 74 2d 6e 61 6d 65 20 27 44 4f 4e 4f 54 52 55 st-name 'DONOTRU
f120: 4e 29 20 3b 3b 20 43 4f 4d 50 4c 45 54 45 44 29 N) ;; COMPLETED)
f130: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
f140: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b flag #f)).. ;
f150: 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 ; -rerun and sta
f160: 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 tus is one of th
f170: 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 e specifed, run
f180: 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 it.. ((and re
f190: 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 run... (let* ((
f1a0: 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 rerunlst (stri
f1b0: 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 ng-split rerun "
f1c0: 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 ,")).... (must-r
f1d0: 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 erun (member (te
f1e0: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
f1f0: 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 stdat) rerunlst)
f200: 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a ))... (debug:
f210: 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d 72 print-info 3 "-r
f220: 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 erun list: " rer
f230: 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 un ", test-statu
f240: 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 s: " (test:get-s
f250: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 22 2c tatus testdat)",
f260: 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d must-rerun: " m
f270: 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 ust-rerun)...
f280: 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 must-rerun))..
f290: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f2a0: 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 66 -info 2 "Rerun f
f2b0: 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 orced for test "
f2c0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
f2d0: 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 tem-path)..
f2e0: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
f2f0: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 )).. ;; -keep
f300: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
f310: 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 run FAIL.. ((
f320: 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 and keepgoing...
f330: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
f340: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
f350: 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a at) '("FAIL"))).
f360: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
f370: 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 lag #f)).. ((
f380: 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a and (not rerun).
f390: 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 .. (member (tes
f3a0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
f3b0: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
f3c0: 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 n/a"))).. (s
f3d0: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
f3e0: 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 .. (else (set
f3f0: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a ! runflag #f))).
f400: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
f410: 20 34 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 4 "RUNNING => r
f420: 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 unflag: " runfla
f430: 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 g " STATE: " (te
f440: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
f450: 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 tdat) " STATUS:
f460: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
f470: 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 us testdat))..
f480: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 (if (not runfla
f490: 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 g).. (if (
f4a0: 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 not parent-test)
f4b0: 0a 09 09 20 20 20 28 69 66 20 28 72 75 6e 73 3a ... (if (runs:
f4c0: 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 lownoise (conc "
f4d0: 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 73 not starting tes
f4e0: 74 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d t" full-test-nam
f4f0: 65 29 20 36 30 29 0a 09 09 20 20 20 20 20 20 20 e) 60)...
f500: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
f510: 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 NOTE: Not starti
f520: 6e 67 20 74 65 73 74 20 22 20 66 75 6c 6c 2d 74 ng test " full-t
f530: 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 est-name " as it
f540: 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 is state \"" (t
f550: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
f560: 73 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 20 stdat) .....
f570: 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 5c "\" and status \
f580: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
f590: 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c 22 tus testdat) "\"
f5a0: 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 22 , use -rerun \""
f5b0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
f5c0: 73 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 20 s testdat).....
f5d0: 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 "\" or -force
f5e0: 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 29 to override")))
f5f0: 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 .. ;; NOTE
f600: 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 : No longer be c
f610: 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 hecking prerequi
f620: 73 69 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c sites here! Will
f630: 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 20 never get here
f640: 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 unless prereqs a
f650: 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 re.. ;;
f660: 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e already met.
f670: 0a 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 .. ;; This
f680: 20 77 6f 75 6c 64 20 62 65 20 61 20 67 72 65 61 would be a grea
f690: 74 20 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 68 t place to do th
f6a0: 65 20 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a 09 e process-fork..
f6b0: 20 20 20 20 20 20 20 3b 3b 20 0a 09 20 20 20 20 ;; ..
f6c0: 20 20 20 28 6c 65 74 20 28 28 73 6b 69 70 2d 74 (let ((skip-t
f6d0: 65 73 74 20 20 20 23 66 29 0a 09 09 20 20 20 20 est #f)...
f6e0: 20 28 73 6b 69 70 2d 63 68 65 63 6b 20 20 28 63 (skip-check (c
f6f0: 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 onfigf:get-secti
f700: 6f 6e 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b on test-conf "sk
f710: 69 70 22 29 29 29 0a 09 09 20 28 63 6f 6e 64 20 ip")))... (cond
f720: 0a 09 09 20 20 3b 3b 20 48 61 76 65 20 74 6f 20 ... ;; Have to
f730: 63 68 65 63 6b 20 66 6f 72 20 73 6b 69 70 20 63 check for skip c
f740: 6f 6e 64 69 74 69 6f 6e 73 2e 20 54 68 69 73 20 onditions. This
f750: 6f 6e 65 20 73 6b 69 70 73 20 69 66 20 74 68 65 one skips if the
f760: 72 65 20 61 72 65 20 73 61 6d 65 2d 6e 61 6d 65 re are same-name
f770: 64 20 74 65 73 74 73 0a 09 09 20 20 3b 3b 20 63 d tests... ;; c
f780: 75 72 72 65 6e 74 6c 79 20 72 75 6e 6e 69 6e 67 urrently running
f790: 0a 09 09 20 20 28 28 61 6e 64 20 73 6b 69 70 2d ... ((and skip-
f7a0: 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 69 67 check....(config
f7b0: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f f:lookup test-co
f7c0: 6e 66 20 22 73 6b 69 70 22 20 22 70 72 65 76 72 nf "skip" "prevr
f7d0: 75 6e 6e 69 6e 67 22 29 29 0a 09 09 20 20 20 3b unning"))... ;
f7e0: 3b 20 72 75 6e 2d 69 64 73 20 3d 20 23 66 20 6d ; run-ids = #f m
f7f0: 65 61 6e 73 20 2a 61 6c 6c 2a 20 72 75 6e 73 0a eans *all* runs.
f800: 09 09 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6e .. (let ((runn
f810: 69 6e 67 2d 74 65 73 74 73 20 28 72 6d 74 3a 67 ing-tests (rmt:g
f820: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
f830: 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 66 75 6c s-mindata #f ful
f840: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 52 l-test-name '("R
f850: 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 48 UNNING" "REMOTEH
f860: 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e 43 OSTSTART" "LAUNC
f870: 48 45 44 22 29 20 27 28 29 20 23 66 29 29 29 0a HED") '() #f))).
f880: 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 .. (if (not
f890: 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 6e 67 2d 74 (null? running-t
f8a0: 65 73 74 73 29 29 20 3b 3b 20 68 61 76 65 20 74 ests)) ;; have t
f8b0: 6f 20 73 6b 69 70 20 0a 09 09 09 20 28 73 65 74 o skip .... (set
f8c0: 21 20 73 6b 69 70 2d 74 65 73 74 20 22 53 6b 69 ! skip-test "Ski
f8d0: 70 70 69 6e 67 20 64 75 65 20 74 6f 20 70 72 65 pping due to pre
f8e0: 76 69 6f 75 73 20 74 65 73 74 73 20 72 75 6e 6e vious tests runn
f8f0: 69 6e 67 22 29 29 29 29 0a 09 09 20 20 28 28 61 ing"))))... ((a
f900: 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a 09 09 nd skip-check...
f910: 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 .(configf:lookup
f920: 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 test-conf "skip
f930: 22 20 22 66 69 6c 65 65 78 69 73 74 73 22 29 29 " "fileexists"))
f940: 0a 09 09 20 20 20 28 69 66 20 28 66 69 6c 65 2d ... (if (file-
f950: 65 78 69 73 74 73 3f 20 28 63 6f 6e 66 69 67 66 exists? (configf
f960: 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e :lookup test-con
f970: 66 20 22 73 6b 69 70 22 20 22 66 69 6c 65 65 78 f "skip" "fileex
f980: 69 73 74 73 22 29 29 0a 09 09 20 20 20 20 20 20 ists"))...
f990: 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 74 (set! skip-test
f9a0: 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 6e 67 (conc "Skipping
f9b0: 20 64 75 65 20 74 6f 20 65 78 69 73 74 61 6e 63 due to existanc
f9c0: 65 20 6f 66 20 66 69 6c 65 20 22 20 28 63 6f 6e e of file " (con
f9d0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 figf:lookup test
f9e0: 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 69 -conf "skip" "fi
f9f0: 6c 65 65 78 69 73 74 73 22 29 29 29 29 29 29 0a leexists")))))).
fa00: 09 09 20 28 69 66 20 73 6b 69 70 2d 74 65 73 74 .. (if skip-test
fa10: 0a 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ... (begin..
fa20: 09 20 20 20 20 20 20 20 28 6d 74 3a 74 65 73 74 . (mt:test
fa30: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
fa40: 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 s-by-id run-id t
fa50: 65 73 74 2d 69 64 20 22 43 4f 4d 50 4c 45 54 45 est-id "COMPLETE
fa60: 44 22 20 22 53 4b 49 50 22 20 73 6b 69 70 2d 74 D" "SKIP" skip-t
fa70: 65 73 74 29 0a 09 09 20 20 20 20 20 20 20 28 64 est)... (d
fa80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
fa90: 31 20 22 53 4b 49 50 50 49 4e 47 20 54 65 73 74 1 "SKIPPING Test
faa0: 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d " full-test-nam
fab0: 65 20 22 20 64 75 65 20 74 6f 20 22 20 73 6b 69 e " due to " ski
fac0: 70 2d 74 65 73 74 29 29 0a 09 09 20 20 20 20 20 p-test))...
fad0: 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 (if (not (launch
fae0: 2d 74 65 73 74 20 74 65 73 74 2d 69 64 20 72 75 -test test-id ru
faf0: 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 n-id run-info ke
fb00: 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 yvals runname te
fb10: 73 74 2d 63 6f 6e 66 20 74 65 73 74 2d 6e 61 6d st-conf test-nam
fb20: 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d e test-path item
fb30: 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 09 20 dat flags))....
fb40: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 28 70 72 (begin.... (pr
fb50: 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c int "ERROR: Fail
fb60: 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 ed to launch the
fb70: 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 test. Exiting a
fb80: 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 s soon as possib
fb90: 6c 65 22 29 0a 09 09 09 20 20 20 28 73 65 74 21 le").... (set!
fba0: 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 *globalexitstat
fbb0: 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 09 20 20 us* 1) ;; ....
fbc0: 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
fbd0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
fbe0: 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c s-id) signal/kil
fbf0: 6c 29 29 29 29 29 29 29 29 0a 09 28 28 4b 49 4c l))))))))..((KIL
fc00: 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 LED) .. (debug:p
fc10: 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 rint 1 "NOTE: "
fc20: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 full-test-name "
fc30: 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e is already runn
fc40: 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 ing or was expli
fc50: 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 ctly killed, use
fc60: 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 -force to launc
fc70: 68 20 69 74 2e 22 29 0a 09 20 28 68 61 73 68 2d h it.").. (hash-
fc80: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
fc90: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m
fca0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
fcb0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 me test-name tes
fcc0: 74 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 t-path) 'DONOTRU
fcd0: 4e 29 29 20 3b 3b 20 4b 49 4c 4c 45 44 29 29 0a N)) ;; KILLED)).
fce0: 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f .((LAUNCHED REMO
fcf0: 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e TEHOSTSTART RUNN
fd00: 49 4e 47 29 20 20 0a 09 20 28 64 65 62 75 67 3a ING) .. (debug:
fd10: 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 print 2 "NOTE: "
fd20: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 test-name " is
fd30: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 already running"
fd40: 29 29 0a 09 3b 3b 20 28 69 66 20 28 3e 20 28 2d ))..;; (if (> (-
fd50: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
fd60: 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 s)(+ (db:test-ge
fd70: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 t-event_time tes
fd80: 74 64 61 74 29 0a 09 3b 3b 20 09 09 09 20 20 20 tdat)..;; ...
fd90: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
fda0: 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 -run_duration te
fdb0: 73 74 64 61 74 29 29 29 0a 09 3b 3b 20 09 28 6f stdat)))..;; .(o
fdc0: 72 20 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d r incomplete-tim
fdd0: 65 6f 75 74 0a 09 3b 3b 20 09 20 20 20 20 36 30 eout..;; . 60
fde0: 30 30 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 00)) ;; i.e. no
fdf0: 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 update for more
fe00: 74 68 61 6e 20 36 30 30 30 20 73 65 63 6f 6e 64 than 6000 second
fe10: 73 0a 09 3b 3b 20 20 20 20 20 20 28 62 65 67 69 s..;; (begi
fe20: 6e 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 64 65 n..;; (de
fe30: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
fe40: 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 NING: Test " tes
fe50: 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 t-name " appears
fe60: 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 to be dead. For
fe70: 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 cing it to state
fe80: 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 INCOMPLETE and
fe90: 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 status STUCK/DEA
fea0: 44 22 29 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 D")..;; (
feb0: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
fec0: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
fed0: 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 st-id "INCOMPLET
fee0: 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 E" "STUCK/DEAD"
fef0: 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 20 20 "" #f))..;;
ff00: 20 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 ;; (tests:tes
ff10: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 65 t-set-status! te
ff20: 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 st-id "INCOMPLET
ff30: 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 E" "STUCK/DEAD"
ff40: 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 20 20 "" #f))..;;
ff50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
ff60: 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 "NOTE: " test-na
ff70: 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 me " is already
ff80: 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c running")))..(el
ff90: 73 65 20 20 20 20 20 20 0a 09 20 28 64 65 62 75 se .. (debu
ffa0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
ffb0: 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e : Failed to laun
ffc0: 63 68 20 74 65 73 74 20 22 20 66 75 6c 6c 2d 74 ch test " full-t
ffd0: 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 est-name ". Unre
ffe0: 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 cognised state "
fff0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
10000 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 63 61 testdat)).. (ca
10010 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 se (string->symb
10020 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 ol (test:get-sta
10030 74 65 20 74 65 73 74 64 61 74 29 29 20 0a 09 20 te testdat)) ..
10040 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 20 49 4e ((COMPLETED IN
10050 43 4f 4d 50 4c 45 54 45 29 0a 09 20 20 20 20 28 COMPLETE).. (
10060 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
10070 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
10080 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
10090 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
100a0 65 20 74 65 73 74 2d 70 61 74 68 29 20 27 44 4f e test-path) 'DO
100b0 4e 4f 54 52 55 4e 29 29 0a 09 20 20 20 28 65 6c NOTRUN)).. (el
100c0 73 65 0a 09 20 20 20 20 28 68 61 73 68 2d 74 61 se.. (hash-ta
100d0 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
100e0 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b gistry (runs:mak
100f0 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
10100 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
10110 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 path) 'DONOTRUN)
10120 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
10130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10160 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10170 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 =.;; END OF NEW
10180 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d STUFF.;;========
10190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
101d0 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 (define (get-dir
101e0 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 -up-n dir . para
101f0 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 ms) . (let ((dp
10200 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
10210 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 lit dir "/"))..(
10220 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c count (if (nul
10230 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 l? params) 1 (ca
10240 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 r params)))).
10250 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
10260 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
10270 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 . (take dp
10280 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 arts (- (length
10290 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a dparts) count)).
102a0 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a . "/")))).
102b0 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
102c0 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d ecursive-delete-
102d0 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 72 with-error-msg r
102e0 65 61 6c 2d 64 69 72 29 0a 20 20 28 69 66 20 28 eal-dir). (if (
102f0 3e 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 > (system (conc
10300 22 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 "rm -rf " real-d
10310 69 72 29 29 20 30 29 0a 20 20 20 20 20 20 28 62 ir)) 0). (b
10320 65 67 69 6e 0a 09 3b 3b 20 46 41 49 4c 45 44 2c egin..;; FAILED,
10330 20 70 6f 73 73 69 62 6c 79 20 64 75 65 20 74 6f possibly due to
10340 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 6f permissions, do
10350 20 63 68 6d 6f 64 20 61 2b 72 77 78 20 74 68 65 chmod a+rwx the
10360 6e 20 74 72 79 20 6f 6e 65 20 6d 6f 72 65 20 74 n try one more t
10370 69 6d 65 0a 09 28 73 79 73 74 65 6d 20 28 63 6f ime..(system (co
10380 6e 63 20 22 63 68 6d 6f 64 20 2d 52 20 61 2b 72 nc "chmod -R a+r
10390 77 78 20 22 20 72 65 61 6c 2d 64 69 72 29 29 0a wx " real-dir)).
103a0 09 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 .(if (> (system
103b0 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 (conc "rm -rf "
103c0 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 20 real-dir)) 0)..
103d0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
103e0 30 20 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 0 "ERROR: There
103f0 77 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 was a problem re
10400 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 moving " real-di
10410 72 20 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 r " with rm -f")
10420 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
10430 75 6e 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d uns:safe-delete-
10440 74 65 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 test-dir real-di
10450 72 29 0a 20 20 3b 3b 20 66 69 72 73 74 20 64 65 r). ;; first de
10460 6c 65 74 65 20 61 6c 6c 20 73 75 62 2d 64 69 72 lete all sub-dir
10470 65 63 74 6f 72 69 65 73 0a 20 20 28 64 69 72 65 ectories. (dire
10480 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 28 ctory-fold . (
10490 6c 61 6d 62 64 61 20 28 66 20 78 29 0a 20 20 20 lambda (f x).
104a0 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 6d (let ((fullnam
104b0 65 20 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 72 e (conc real-dir
104c0 20 22 2f 22 20 66 29 29 29 0a 20 20 20 20 20 20 "/" f))).
104d0 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f (if (directory?
104e0 20 66 75 6c 6c 6e 61 6d 65 29 28 72 75 6e 73 3a fullname)(runs:
104f0 72 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 recursive-delete
10500 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 -with-error-msg
10510 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 fullname))).
10520 20 28 2b 20 31 20 78 29 29 0a 20 20 20 30 20 72 (+ 1 x)). 0 r
10530 65 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 68 eal-dir). ;; th
10540 65 6e 20 66 69 6c 65 73 20 6f 74 68 65 72 20 74 en files other t
10550 68 61 6e 20 2a 74 65 73 74 64 61 74 2e 64 62 2a han *testdat.db*
10560 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f . (directory-fo
10570 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ld . (lambda (
10580 66 20 78 29 0a 20 20 20 20 20 28 6c 65 74 20 28 f x). (let (
10590 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 (fullname (conc
105a0 72 65 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 29 real-dir "/" f))
105b0 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f ). (if (no
105c0 74 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 t (string-search
105d0 20 28 72 65 67 65 78 70 20 22 74 65 73 74 64 61 (regexp "testda
105e0 74 2e 64 62 22 29 20 66 29 29 0a 09 20 20 20 28 t.db") f)).. (
105f0 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 runs:recursive-d
10600 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 elete-with-error
10610 2d 6d 73 67 20 66 75 6c 6c 6e 61 6d 65 29 29 29 -msg fullname)))
10620 0a 20 20 20 20 20 28 2b 20 31 20 78 29 29 0a 20 . (+ 1 x)).
10630 20 20 30 20 72 65 61 6c 2d 64 69 72 29 0a 20 20 0 real-dir).
10640 3b 3b 20 74 68 65 6e 20 74 68 65 20 65 6e 74 69 ;; then the enti
10650 72 65 20 64 69 72 65 63 74 6f 72 79 0a 20 20 28 re directory. (
10660 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 runs:recursive-d
10670 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 elete-with-error
10680 2d 6d 73 67 20 72 65 61 6c 2d 64 69 72 29 29 0a -msg real-dir)).
10690 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a .;; Remove runs.
106a0 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 ;; fields are pa
106b0 73 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 ssing in through
106c0 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 .;; action:.;;
106d0 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 'remove-runs.
106e0 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 ;; 'set-state
106f0 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 -status.;;.;; NB
10700 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 // should pass i
10710 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 n keys?.;;.(defi
10720 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 ne (runs:operate
10730 2d 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 -on action targe
10740 74 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 t runnamepatt te
10750 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 stpatt #!key (st
10760 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 ate #f)(status #
10770 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 f)(new-state-sta
10780 74 75 73 20 23 66 29 28 72 65 6d 6f 76 65 2d 64 tus #f)(remove-d
10790 61 74 61 2d 6f 6e 6c 79 20 23 66 29 29 0a 20 20 ata-only #f)).
107a0 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 (common:clear-ca
107b0 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 61 ches) ;; clear a
107c0 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 74 ll caches. (let
107d0 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
107e0 20 23 66 29 0a 09 20 28 74 61 73 6b 73 2d 64 62 #f).. (tasks-db
107f0 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e (tasks:open
10800 2d 64 62 29 29 0a 09 20 28 6b 65 79 73 20 20 20 -db)).. (keys
10810 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b (rmt:get-k
10820 65 79 73 29 29 0a 09 20 28 72 75 6e 64 61 74 20 eys)).. (rundat
10830 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d 72 75 (mt:get-ru
10840 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 73 20 ns-by-patt keys
10850 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 runnamepatt targ
10860 65 74 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 et)).. (header
10870 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
10880 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 rundat 0)).. (r
10890 75 6e 73 20 20 20 20 20 20 20 20 20 28 76 65 63 uns (vec
108a0 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 tor-ref rundat 1
108b0 29 29 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 )).. (states
108c0 20 20 20 28 69 66 20 73 74 61 74 65 20 20 28 73 (if state (s
108d0 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 tring-split stat
108e0 65 20 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 e ",") '()))..
108f0 28 73 74 61 74 75 73 65 73 20 20 20 20 20 28 69 (statuses (i
10900 66 20 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 f status (string
10910 2d 73 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c -split status ",
10920 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 ") '())).. (stat
10930 65 2d 73 74 61 74 75 73 20 28 69 66 20 28 73 74 e-status (if (st
10940 72 69 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d ring? new-state-
10950 73 74 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d status) (string-
10960 73 70 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d split new-state-
10970 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 status ",") '(#f
10980 20 23 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 #f)))). (deb
10990 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
109a0 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e "runs:operate-on
109b0 20 3d 3e 20 48 65 61 64 65 72 3a 20 22 20 68 65 => Header: " he
109c0 61 64 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 ader " action: "
109d0 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 action " new-st
109e0 61 74 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 ate-status: " ne
109f0 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a w-state-status).
10a00 20 20 20 20 28 69 66 20 28 3e 20 32 20 28 6c 65 (if (> 2 (le
10a10 6e 67 74 68 20 73 74 61 74 65 2d 73 74 61 74 75 ngth state-statu
10a20 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 s))..(begin.. (
10a30 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
10a40 52 52 4f 52 3a 20 74 68 65 20 70 61 72 61 6d 65 RROR: the parame
10a50 74 65 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 74 ter to -set-stat
10a60 65 2d 73 74 61 74 75 73 20 69 73 20 61 20 63 6f e-status is a co
10a70 6d 6d 61 20 64 65 6c 69 6d 69 74 65 64 20 73 74 mma delimited st
10a80 72 69 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c ring. E.g. COMPL
10a90 45 54 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 28 ETED,FAIL").. (
10aa0 65 78 69 74 29 29 29 0a 20 20 20 20 28 66 6f 72 exit))). (for
10ab0 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
10ac0 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 da (run).
10ad0 28 6c 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 (let ((runkey (s
10ae0 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
10af0 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
10b00 6b 29 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 k).......(db:get
10b10 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
10b20 20 72 75 6e 20 68 65 61 64 65 72 20 6b 29 29 20 run header k))
10b30 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 20 20 20 keys) "/"))..
10b40 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 (dirs-to-remov
10b50 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 e (make-hash-tab
10b60 6c 65 29 29 0a 09 20 20 20 20 20 28 70 72 6f 63 le)).. (proc
10b70 2d 67 65 74 2d 74 65 73 74 73 20 28 6c 61 6d 62 -get-tests (lamb
10b80 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 09 09 20 da (run-id)....
10b90 20 20 20 20 20 28 6d 74 3a 67 65 74 2d 74 65 73 (mt:get-tes
10ba0 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 ts-for-run run-i
10bb0 64 0a 09 09 09 09 09 09 20 20 20 20 74 65 73 74 d....... test
10bc0 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 patt states stat
10bd0 75 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 6e uses....... n
10be0 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 09 09 09 ot-in: #f......
10bf0 09 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 . sort-by: (c
10c00 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 ase action......
10c10 09 09 20 20 20 20 20 20 20 28 28 72 65 6d 6f 76 .. ((remov
10c20 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 69 72 29 e-runs) 'rundir)
10c30 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 ........ (
10c40 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 27 65 else 'e
10c50 76 65 6e 74 5f 74 69 6d 65 29 29 29 29 29 29 0a vent_time)))))).
10c60 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 . (let* ((run-id
10c70 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 (db:get-valu
10c80 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
10c90 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 09 header "id"))...
10ca0 28 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 (run-state (db:g
10cb0 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
10cc0 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 73 er run header "s
10cd0 74 61 74 65 22 29 29 0a 09 09 28 72 75 6e 2d 6e tate"))...(run-n
10ce0 61 6d 65 20 20 28 64 62 3a 67 65 74 2d 76 61 6c ame (db:get-val
10cf0 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
10d00 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
10d10 22 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 "))...(tests
10d20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
10d30 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 ? run-state "loc
10d40 6b 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 ked"))....
10d50 20 28 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 (proc-get-tests
10d60 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 20 run-id)....
10d70 20 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 74 '()))...(last
10d80 74 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 tpath "/does/not
10d90 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 /exist/I/hope"))
10da0 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
10db0 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f t-info 4 "runs:o
10dc0 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 perate-on run="
10dd0 72 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 20 run ", header="
10de0 68 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 20 header).. (if
10df0 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
10e00 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 s)).. (beg
10e10 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 69 in... (case acti
10e20 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 65 on... ((remove
10e30 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 3b 3b 20 -runs)... ;;
10e40 73 65 65 6b 20 61 6e 64 20 6b 69 6c 6c 20 69 6e seek and kill in
10e50 20 66 6c 69 67 68 74 20 2d 72 75 6e 74 65 73 74 flight -runtest
10e60 73 20 77 69 74 68 20 25 20 61 73 20 74 65 73 74 s with % as test
10e70 70 61 74 74 20 68 65 72 65 0a 09 09 20 20 20 20 patt here...
10e80 28 69 66 20 28 65 71 75 61 6c 3f 20 74 65 73 74 (if (equal? test
10e90 70 61 74 74 20 22 25 22 29 0a 09 09 09 28 74 61 patt "%")....(ta
10ea0 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 72 20 sks:kill-runner
10eb0 74 61 73 6b 73 2d 64 62 20 74 61 72 67 65 74 20 tasks-db target
10ec0 72 75 6e 2d 6e 61 6d 65 29 0a 09 09 09 28 64 65 run-name)....(de
10ed0 62 75 67 3a 70 72 69 6e 74 20 30 20 22 6e 6f 74 bug:print 0 "not
10ee0 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6b attempting to k
10ef0 69 6c 6c 20 61 6e 79 20 72 75 6e 20 6c 61 75 6e ill any run laun
10f00 63 68 65 72 20 70 72 6f 63 65 73 73 65 73 20 61 cher processes a
10f10 73 20 74 65 73 74 70 61 74 74 20 69 73 20 22 20 s testpatt is "
10f20 74 65 73 74 70 61 74 74 29 29 0a 09 09 20 20 20 testpatt))...
10f30 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
10f40 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 "Removing tests
10f50 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 for run: " runke
10f60 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 y " " (db:get-va
10f70 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
10f80 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d n header "runnam
10f90 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 74 e")))... ((set
10fa0 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 -state-status)..
10fb0 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
10fc0 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 t 1 "Modifying s
10fd0 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 tate and staus f
10fe0 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e or tests for run
10ff0 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
11000 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
11010 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
11020 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 r "runname")))..
11030 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 . ((print-run)
11040 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
11050 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 20 int 1 "Printing
11060 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 info for run " r
11070 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 unkey ", run=" r
11080 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 65 un ", tests=" te
11090 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 20 sts ", header="
110a0 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 63 header)... ac
110b0 74 69 6f 6e 29 0a 09 09 20 20 20 28 28 72 75 6e tion)... ((run
110c0 2d 77 61 69 74 29 0a 09 09 20 20 20 20 28 64 65 -wait)... (de
110d0 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 61 69 bug:print 1 "Wai
110e0 74 69 6e 67 20 66 6f 72 20 72 75 6e 20 22 20 72 ting for run " r
110f0 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 unkey ", run=" r
11100 75 6e 6e 61 6d 65 70 61 74 74 20 22 20 74 6f 20 unnamepatt " to
11110 63 6f 6d 70 6c 65 74 65 22 29 29 0a 09 09 20 20 complete"))...
11120 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 64 65 (else... (de
11130 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
11140 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 72 65 63 "action not rec
11150 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 6f 6e ognised " action
11160 29 29 29 0a 09 09 20 28 6c 65 74 20 28 28 73 6f )))... (let ((so
11170 72 74 65 64 2d 74 65 73 74 73 20 20 20 20 20 28 rted-tests (
11180 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d 62 sort tests (lamb
11190 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 64 da (a b)(let ((d
111a0 69 72 61 20 3b 3b 20 28 72 6d 74 3a 73 64 62 2d ira ;; (rmt:sdb-
111b0 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 09 09 qry 'getstr ....
111c0 09 09 09 09 09 09 20 28 64 62 3a 74 65 73 74 2d ...... (db:test-
111d0 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 20 3b get-rundir a)) ;
111e0 3b 20 29 20 20 3b 3b 20 28 66 69 6c 65 64 62 3a ; ) ;; (filedb:
111f0 67 65 74 2d 70 61 74 68 20 2a 66 64 62 2a 20 28 get-path *fdb* (
11200 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
11210 69 72 20 61 29 29 29 0a 09 09 09 09 09 09 09 09 ir a))).........
11220 09 28 64 69 72 62 20 3b 3b 20 28 72 6d 74 3a 73 .(dirb ;; (rmt:s
11230 64 62 2d 71 72 79 20 27 67 65 74 73 74 72 20 0a db-qry 'getstr .
11240 09 09 09 09 09 09 09 09 09 20 28 64 62 3a 74 65 ......... (db:te
11250 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 st-get-rundir b)
11260 29 29 20 3b 3b 20 29 20 3b 3b 20 28 28 66 69 6c )) ;; ) ;; ((fil
11270 65 64 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 edb:get-path *fd
11280 62 2a 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d b* (db:test-get-
11290 72 75 6e 64 69 72 20 62 29 29 29 29 0a 09 09 09 rundir b))))....
112a0 09 09 09 09 09 20 20 20 20 28 69 66 20 28 61 6e ..... (if (an
112b0 64 20 28 73 74 72 69 6e 67 3f 20 64 69 72 61 29 d (string? dira)
112c0 28 73 74 72 69 6e 67 3f 20 64 69 72 62 29 29 0a (string? dirb)).
112d0 09 09 09 09 09 09 09 09 09 28 3e 20 28 73 74 72 .........(> (str
112e0 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 29 ing-length dira)
112f0 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
11300 69 72 62 29 29 0a 09 09 09 09 09 09 09 09 09 23 irb))..........#
11310 66 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 f)))))...
11320 28 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 (toplevel-retrie
11330 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
11340 6c 65 29 29 20 3b 3b 20 74 72 79 20 74 68 72 65 le)) ;; try thre
11350 65 20 74 69 6d 65 73 20 74 6f 20 6c 6f 6f 70 20 e times to loop
11360 74 68 72 6f 75 67 68 20 61 6e 64 20 72 65 6d 6f through and remo
11370 76 65 20 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 ve top level tes
11380 74 73 0a 09 09 20 20 20 20 20 20 20 28 74 65 73 ts... (tes
11390 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 20 28 6d t-retry-time (m
113a0 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
113b0 0a 09 09 20 20 20 20 20 20 20 28 61 6c 6c 6f 77 ... (allow
113c0 2d 72 75 6e 2d 74 69 6d 65 20 20 20 31 30 29 29 -run-time 10))
113d0 20 3b 3b 20 73 65 63 6f 6e 64 73 20 74 6f 20 61 ;; seconds to a
113e0 6c 6c 6f 77 20 66 6f 72 20 6b 69 6c 6c 69 6e 67 llow for killing
113f0 20 74 65 73 74 73 20 62 65 66 6f 72 65 20 6a 75 tests before ju
11400 73 74 20 62 72 75 74 61 6c 6c 79 20 6b 69 6c 6c st brutally kill
11410 69 6e 67 20 27 65 6d 0a 09 09 20 20 20 28 6c 65 ing 'em... (le
11420 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 20 28 63 t loop ((test (c
11430 61 72 20 73 6f 72 74 65 64 2d 74 65 73 74 73 29 ar sorted-tests)
11440 29 0a 09 09 09 20 20 20 20 20 20 28 74 61 6c 20 ).... (tal
11450 20 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 (cdr sorted-tes
11460 74 73 29 29 29 0a 09 09 20 20 20 20 20 28 6c 65 ts)))... (le
11470 74 2a 20 28 28 74 65 73 74 2d 69 64 20 20 20 20 t* ((test-id
11480 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
11490 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 id test))....
114a0 20 28 6e 65 77 2d 74 65 73 74 2d 64 61 74 20 20 (new-test-dat
114b0 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
114c0 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
114d0 74 65 73 74 2d 69 64 29 29 29 0a 09 09 20 20 20 test-id)))...
114e0 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6e 65 77 (if (not new
114f0 2d 74 65 73 74 2d 64 61 74 29 0a 09 09 09 20 20 -test-dat)....
11500 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 (begin....
11510 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
11520 45 52 52 4f 52 3a 20 57 65 20 68 61 76 65 20 61 ERROR: We have a
11530 20 74 65 73 74 2d 69 64 20 6f 66 20 22 20 74 65 test-id of " te
11540 73 74 2d 69 64 20 22 20 62 75 74 20 6e 6f 20 72 st-id " but no r
11550 65 63 6f 72 64 20 77 61 73 20 66 6f 75 6e 64 2e ecord was found.
11560 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 63 6b 69 6e NOTE: No lockin
11570 67 20 6f 66 20 72 65 63 6f 72 64 73 20 69 73 20 g of records is
11580 64 6f 6e 65 20 62 65 74 77 65 65 6e 20 70 72 6f done between pro
11590 63 65 73 73 65 73 2c 20 64 6f 20 6e 6f 74 20 73 cesses, do not s
115a0 69 6d 75 6c 74 61 6e 65 6f 75 73 6c 79 20 72 65 imultaneously re
115b0 6d 6f 76 65 20 74 68 65 20 73 61 6d 65 20 72 75 move the same ru
115c0 6e 20 66 72 6f 6d 20 74 77 6f 20 70 72 6f 63 65 n from two proce
115d0 73 73 65 73 21 22 29 0a 09 09 09 20 20 20 20 20 sses!")....
115e0 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
115f0 74 61 6c 29 29 0a 09 09 09 09 20 28 6c 6f 6f 70 tal))..... (loop
11600 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
11610 61 6c 29 29 29 29 0a 09 09 09 20 20 20 28 6c 65 al)))).... (le
11620 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 t* ((item-path
11630 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
11640 69 74 65 6d 2d 70 61 74 68 20 6e 65 77 2d 74 65 item-path new-te
11650 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 20 28 st-dat))..... (
11660 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 20 28 64 test-name (d
11670 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
11680 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 ame new-test-dat
11690 29 29 0a 09 09 09 09 20 20 28 72 75 6e 2d 64 69 ))..... (run-di
116a0 72 20 20 20 20 20 20 20 3b 3b 28 66 69 6c 65 64 r ;;(filed
116b0 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 62 2a b:get-path *fdb*
116c0 0a 09 09 09 09 20 20 20 3b 3b 20 28 72 6d 74 3a ..... ;; (rmt:
116d0 73 64 62 2d 71 72 79 20 27 67 65 74 69 64 20 0a sdb-qry 'getid .
116e0 09 09 09 09 20 20 20 28 64 62 3a 74 65 73 74 2d .... (db:test-
116f0 67 65 74 2d 72 75 6e 64 69 72 20 6e 65 77 2d 74 get-rundir new-t
11700 65 73 74 2d 64 61 74 29 29 20 3b 3b 20 29 20 20 est-dat)) ;; )
11710 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 20 ;; run dir is
11720 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 72 from the link tr
11730 65 65 0a 09 09 09 09 20 20 28 74 65 73 74 2d 73 ee..... (test-s
11740 74 61 74 65 20 20 20 20 28 64 62 3a 74 65 73 74 tate (db:test
11750 2d 67 65 74 2d 73 74 61 74 65 20 6e 65 77 2d 74 -get-state new-t
11760 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 20 est-dat)).....
11770 28 74 65 73 74 2d 66 75 6c 6c 6e 20 20 20 20 28 (test-fulln (
11780 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c db:test-get-full
11790 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 name new-test-da
117a0 74 29 29 0a 09 09 09 09 20 20 28 75 6e 61 6d 65 t))..... (uname
117b0 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 (db:tes
117c0 74 2d 67 65 74 2d 75 6e 61 6d 65 20 20 20 20 6e t-get-uname n
117d0 65 77 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 09 ew-test-dat))...
117e0 09 09 20 20 28 74 6f 70 6c 65 76 65 6c 2d 77 69 .. (toplevel-wi
117f0 74 68 2d 63 68 69 6c 64 72 65 6e 20 28 61 6e 64 th-children (and
11800 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 73 (db:test-get-is
11810 2d 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 29 0a -toplevel test).
11820 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 3e ....... (>
11830 20 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 (rmt:test-tople
11840 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 vel-num-items ru
11850 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 20 n-id test-name)
11860 30 29 29 29 29 0a 09 09 09 20 20 20 20 20 28 63 0)))).... (c
11870 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 20 20 ase action....
11880 20 20 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 ((remove-ru
11890 6e 73 29 0a 09 09 09 09 3b 3b 20 69 66 20 74 68 ns).....;; if th
118a0 65 20 74 65 73 74 20 69 73 20 61 20 74 6f 70 6c e test is a topl
118b0 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 evel-with-childr
118c0 65 6e 20 69 73 73 75 65 20 61 6e 20 65 72 72 6f en issue an erro
118d0 72 20 61 6e 64 20 64 6f 20 6e 6f 74 20 72 65 6d r and do not rem
118e0 6f 76 65 0a 09 09 09 09 28 69 66 20 74 6f 70 6c ove.....(if topl
118f0 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 evel-with-childr
11900 65 6e 0a 09 09 09 09 20 20 20 20 28 62 65 67 69 en..... (begi
11910 6e 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 62 n..... (deb
11920 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
11930 49 4e 47 3a 20 73 6b 69 70 70 69 6e 67 20 72 65 ING: skipping re
11940 6d 6f 76 61 6c 20 6f 66 20 22 20 74 65 73 74 2d moval of " test-
11950 66 75 6c 6c 6e 20 22 20 77 69 74 68 20 72 75 6e fulln " with run
11960 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 61 -id " run-id " a
11970 73 20 69 74 20 68 61 73 20 73 75 62 20 74 65 73 s it has sub tes
11980 74 73 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 ts")..... (
11990 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
119a0 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 73 toplevel-retries
119b0 20 74 65 73 74 2d 66 75 6c 6c 6e 20 28 2b 20 28 test-fulln (+ (
119c0 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
119d0 65 66 61 75 6c 74 20 74 6f 70 6c 65 76 65 6c 2d efault toplevel-
119e0 72 65 74 72 69 65 73 20 74 65 73 74 2d 66 75 6c retries test-ful
119f0 6c 6e 20 30 29 20 31 29 29 0a 09 09 09 09 20 20 ln 0) 1)).....
11a00 20 20 20 20 28 69 66 20 28 3e 20 28 68 61 73 68 (if (> (hash
11a10 2d 74 61 62 6c 65 2d 72 65 66 20 74 6f 70 6c 65 -table-ref tople
11a20 76 65 6c 2d 72 65 74 72 69 65 73 20 74 65 73 74 vel-retries test
11a30 2d 66 75 6c 6c 6e 29 20 33 29 0a 09 09 09 09 09 -fulln) 3)......
11a40 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
11a50 3f 20 74 61 6c 29 29 0a 09 09 09 09 09 20 20 20 ? tal))......
11a60 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
11a70 6c 29 28 63 64 72 20 74 61 6c 29 29 29 20 3b 3b l)(cdr tal))) ;;
11a80 20 6e 6f 20 65 6c 73 65 20 63 6c 61 75 73 65 20 no else clause
11a90 2d 20 64 72 6f 70 20 69 74 20 69 66 20 6e 6f 20 - drop it if no
11aa0 6d 6f 72 65 20 69 6e 20 71 75 65 75 65 20 61 6e more in queue an
11ab0 64 20 3e 20 33 20 74 72 69 65 73 0a 09 09 09 09 d > 3 tries.....
11ac0 09 20 20 28 6c 65 74 20 28 28 6e 65 77 74 61 6c . (let ((newtal
11ad0 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 (append tal (li
11ae0 73 74 20 74 65 73 74 29 29 29 29 0a 09 09 09 09 st test)))).....
11af0 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
11b00 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
11b10 61 6c 29 29 29 29 29 20 3b 3b 20 6c 6f 6f 70 20 al))))) ;; loop
11b20 77 69 74 68 20 74 65 73 74 20 73 74 69 6c 6c 20 with test still
11b30 69 6e 20 71 75 65 75 65 0a 09 09 09 09 20 20 20 in queue.....
11b40 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 (begin.....
11b50 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
11b60 6e 66 6f 20 30 20 22 74 65 73 74 3a 20 22 20 74 nfo 0 "test: " t
11b70 65 73 74 2d 6e 61 6d 65 20 22 20 69 74 65 73 74 est-name " itest
11b80 2d 73 74 61 74 65 3a 20 22 20 74 65 73 74 2d 73 -state: " test-s
11b90 74 61 74 65 29 0a 09 09 09 09 20 20 20 20 20 20 tate).....
11ba0 28 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 74 (if (member test
11bb0 2d 73 74 61 74 65 20 28 6c 69 73 74 20 22 52 55 -state (list "RU
11bc0 4e 4e 49 4e 47 22 20 22 4c 41 55 4e 43 48 45 44 NNING" "LAUNCHED
11bd0 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 " "REMOTEHOSTSTA
11be0 52 54 22 20 22 4b 49 4c 4c 52 45 51 22 29 29 0a RT" "KILLREQ")).
11bf0 09 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ..... (begin...
11c00 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ... (if (not
11c10 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
11c20 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 74 default test-ret
11c30 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 6c ry-time test-ful
11c40 6c 6e 20 23 66 29 29 0a 09 09 09 09 09 09 28 62 ln #f)).......(b
11c50 65 67 69 6e 0a 09 09 09 09 09 09 20 20 3b 3b 20 egin....... ;;
11c60 77 61 6e 74 20 74 6f 20 73 65 74 20 74 6f 20 52 want to set to R
11c70 45 4d 4f 56 49 4e 47 20 42 55 54 20 43 41 4e 4e EMOVING BUT CANN
11c80 4f 54 20 64 6f 20 69 74 20 68 65 72 65 3f 0a 09 OT do it here?..
11c90 09 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 ..... (hash-tab
11ca0 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 74 le-set! test-ret
11cb0 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 6c ry-time test-ful
11cc0 6c 6e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ln (current-seco
11cd0 6e 64 73 29 29 29 29 0a 09 09 09 09 09 20 20 20 nds))))......
11ce0 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
11cf0 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 68 61 73 ent-seconds)(has
11d00 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 h-table-ref test
11d10 2d 72 65 74 72 79 2d 74 69 6d 65 20 74 65 73 74 -retry-time test
11d20 2d 66 75 6c 6c 6e 29 29 20 61 6c 6c 6f 77 2d 72 -fulln)) allow-r
11d30 75 6e 2d 74 69 6d 65 29 0a 09 09 09 09 09 09 3b un-time).......;
11d40 3b 20 54 68 69 73 20 74 65 73 74 20 69 73 20 6e ; This test is n
11d50 6f 74 20 69 6e 20 61 20 63 6f 72 72 65 63 74 20 ot in a correct
11d60 73 74 61 74 65 20 66 6f 72 20 63 6c 65 61 6e 69 state for cleani
11d70 6e 67 20 75 70 2e 20 4c 65 74 27 73 20 74 72 79 ng up. Let's try
11d80 20 73 6f 6d 65 20 67 72 61 63 65 66 75 6c 20 73 some graceful s
11d90 68 75 74 64 6f 77 6e 20 73 74 65 70 73 20 66 69 hutdown steps fi
11da0 72 73 74 0a 09 09 09 09 09 09 3b 3b 20 53 65 74 rst.......;; Set
11db0 20 74 68 65 20 74 65 73 74 20 74 6f 20 22 4b 49 the test to "KI
11dc0 4c 4c 52 45 51 22 20 61 6e 64 20 77 61 69 74 20 LLREQ" and wait
11dd0 66 69 76 65 20 73 65 63 6f 6e 64 73 20 74 68 65 five seconds the
11de0 6e 20 74 72 79 20 61 67 61 69 6e 2e 20 52 65 70 n try again. Rep
11df0 65 61 74 20 75 70 20 74 6f 20 66 69 76 65 20 74 eat up to five t
11e00 69 6d 65 73 20 74 68 65 6e 20 67 69 76 65 0a 09 imes then give..
11e10 09 09 09 09 09 3b 3b 20 75 70 20 61 6e 64 20 62 .....;; up and b
11e20 6c 6f 77 20 69 74 20 61 77 61 79 2e 0a 09 09 09 low it away.....
11e30 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 09 ...(begin.......
11e40 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
11e50 20 22 57 41 52 4e 49 4e 47 3a 20 63 6f 75 6c 64 "WARNING: could
11e60 20 6e 6f 74 20 67 72 61 63 65 66 75 6c 6c 79 20 not gracefully
11e70 72 65 6d 6f 76 65 20 74 65 73 74 20 22 20 74 65 remove test " te
11e80 73 74 2d 66 75 6c 6c 6e 20 22 2c 20 74 72 69 65 st-fulln ", trie
11e90 64 20 74 6f 20 6b 69 6c 6c 20 69 74 20 74 6f 20 d to kill it to
11ea0 6e 6f 20 61 76 61 69 6c 2e 20 46 6f 72 63 69 6e no avail. Forcin
11eb0 67 20 73 74 61 74 65 20 74 6f 20 46 41 49 4c 45 g state to FAILE
11ec0 44 4b 49 4c 4c 20 61 6e 64 20 63 6f 6e 74 69 6e DKILL and contin
11ed0 75 69 6e 67 22 29 0a 09 09 09 09 09 20 20 20 20 uing")......
11ee0 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 (mt:test-set-sta
11ef0 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
11f00 72 75 6e 2d 69 64 20 28 64 62 3a 74 65 73 74 2d run-id (db:test-
11f10 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 46 41 get-id test) "FA
11f20 49 4c 45 44 4b 49 4c 4c 22 20 22 6e 2f 61 22 20 ILEDKILL" "n/a"
11f30 23 66 29 0a 09 09 09 09 09 09 20 20 28 74 68 72 #f)....... (thr
11f40 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a 09 ead-sleep! 1))..
11f50 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 .....(begin.....
11f60 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 . (mt:test-se
11f70 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
11f80 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 64 62 3a y-id run-id (db:
11f90 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
11fa0 29 20 22 4b 49 4c 4c 52 45 51 22 20 22 6e 2f 61 ) "KILLREQ" "n/a
11fb0 22 20 23 66 29 0a 09 09 09 09 09 09 20 20 28 74 " #f)....... (t
11fc0 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 hread-sleep! 1))
11fd0 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 4e 4f )...... ;; NO
11fe0 54 45 3a 20 54 68 69 73 20 69 73 20 73 75 62 6f TE: This is subo
11ff0 70 74 69 6d 61 6c 20 61 73 20 74 68 65 20 74 65 ptimal as the te
12000 73 74 64 61 74 61 20 77 69 6c 6c 20 62 65 20 75 stdata will be u
12010 73 65 64 20 6c 61 74 65 72 20 61 6e 64 20 74 68 sed later and th
12020 65 20 73 74 61 74 65 2f 73 74 61 74 75 73 20 6d e state/status m
12030 61 79 20 68 61 76 65 20 63 68 61 6e 67 65 64 20 ay have changed
12040 2e 2e 2e 0a 09 09 09 09 09 20 20 20 20 28 69 66 ......... (if
12050 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 (null? tal)....
12060 09 09 09 28 6c 6f 6f 70 20 6e 65 77 2d 74 65 73 ...(loop new-tes
12070 74 2d 64 61 74 20 74 61 6c 29 0a 09 09 09 09 09 t-dat tal)......
12080 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 .(loop (car tal)
12090 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 (append tal (lis
120a0 74 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 t new-test-dat))
120b0 29 29 29 0a 09 09 09 09 09 20 20 28 62 65 67 69 )))...... (begi
120c0 6e 0a 09 09 09 09 09 20 20 20 20 28 72 75 6e 73 n...... (runs
120d0 3a 72 65 6d 6f 76 65 2d 74 65 73 74 2d 64 69 72 :remove-test-dir
120e0 65 63 74 6f 72 79 20 64 62 20 6e 65 77 2d 74 65 ectory db new-te
120f0 73 74 2d 64 61 74 20 72 65 6d 6f 76 65 2d 64 61 st-dat remove-da
12100 74 61 2d 6f 6e 6c 79 29 0a 09 09 09 09 09 20 20 ta-only)......
12110 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
12120 3f 20 74 61 6c 29 29 0a 09 09 09 09 09 09 28 6c ? tal)).......(l
12130 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
12140 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 09 r tal))))))))...
12150 09 20 20 20 20 20 20 20 28 28 73 65 74 2d 73 74 . ((set-st
12160 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 09 ate-status).....
12170 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
12180 6f 20 32 20 22 6e 65 77 20 73 74 61 74 65 20 22 o 2 "new state "
12190 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 (car state-stat
121a0 75 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 us) ", new statu
121b0 73 20 22 20 28 63 61 64 72 20 73 74 61 74 65 2d s " (cadr state-
121c0 73 74 61 74 75 73 29 29 0a 09 09 09 09 28 6d 74 status)).....(mt
121d0 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
121e0 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
121f0 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
12200 2d 69 64 20 74 65 73 74 29 20 28 63 61 72 20 73 -id test) (car s
12210 74 61 74 65 2d 73 74 61 74 75 73 29 28 63 61 64 tate-status)(cad
12220 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 r state-status)
12230 23 66 29 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 #f).....(if (not
12240 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
12250 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
12260 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
12270 29 0a 09 09 09 20 20 20 20 20 20 20 28 28 72 75 ).... ((ru
12280 6e 2d 77 61 69 74 29 0a 09 09 09 09 28 64 65 62 n-wait).....(deb
12290 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
122a0 22 73 74 69 6c 6c 20 77 61 69 74 69 6e 67 2c 20 "still waiting,
122b0 22 20 28 6c 65 6e 67 74 68 20 74 65 73 74 73 29 " (length tests)
122c0 20 22 20 74 65 73 74 73 20 73 74 69 6c 6c 20 72 " tests still r
122d0 75 6e 6e 69 6e 67 22 29 0a 09 09 09 09 28 74 68 unning").....(th
122e0 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a read-sleep! 10).
122f0 09 09 09 09 28 6c 65 74 20 28 28 6e 65 77 2d 74 ....(let ((new-t
12300 65 73 74 73 20 28 70 72 6f 63 2d 67 65 74 2d 74 ests (proc-get-t
12310 65 73 74 73 20 72 75 6e 2d 69 64 29 29 29 0a 09 ests run-id)))..
12320 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ... (if (null?
12330 6e 65 77 2d 74 65 73 74 73 29 0a 09 09 09 09 20 new-tests).....
12340 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
12350 74 2d 69 6e 66 6f 20 31 20 22 52 75 6e 20 63 6f t-info 1 "Run co
12360 6d 70 6c 65 74 65 64 20 61 63 63 6f 72 64 69 6e mpleted accordin
12370 67 20 74 6f 20 7a 65 72 6f 20 74 65 73 74 73 20 g to zero tests
12380 6d 61 74 63 68 69 6e 67 20 70 72 6f 76 69 64 65 matching provide
12390 64 20 63 72 69 74 65 72 69 61 2e 22 29 0a 09 09 d criteria.")...
123a0 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
123b0 61 72 20 6e 65 77 2d 74 65 73 74 73 29 28 63 64 ar new-tests)(cd
123c0 72 20 6e 65 77 2d 74 65 73 74 73 29 29 29 29 29 r new-tests)))))
123d0 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 )))... )))
123e0 29 29 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 65 )).. ;; remove
123f0 20 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 6f the run if zero
12400 20 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 20 tests remain..
12410 20 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 6f (if (eq? actio
12420 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a n 'remove-runs).
12430 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 . (let ((r
12440 65 6d 74 65 73 74 73 20 28 6d 74 3a 67 65 74 2d emtests (mt:get-
12450 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 28 64 tests-for-run (d
12460 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
12470 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
12480 20 22 69 64 22 29 20 23 66 20 27 28 22 44 45 4c "id") #f '("DEL
12490 45 54 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 ETED") '("n/a")
124a0 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 not-in: #t)))...
124b0 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 (if (null? remt
124c0 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 ests) ;; no more
124d0 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 tests remaining
124e0 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
124f0 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d dparts (string-
12500 73 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 split lasttpath
12510 22 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 "/")).... (ru
12520 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 npath (conc "/"
12530 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
12540 72 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 rse .......(take
12550 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 dparts (- (leng
12560 74 68 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 th dparts) 1))..
12570 09 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 ....."/"))))...
12580 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
12590 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 nt 1 "Removing r
125a0 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
125b0 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
125c0 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
125d0 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 der "runname") "
125e0 20 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 and related rec
125f0 6f 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 ord")... (
12600 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 72 rmt:delete-run r
12610 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 un-id)...
12620 28 72 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d (rmt:delete-old-
12630 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 deleted-test-rec
12640 6f 72 64 73 29 0a 09 09 20 20 20 20 20 20 20 3b ords)... ;
12650 3b 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 ; (cdb:remote-ru
12660 6e 20 64 62 3a 73 65 74 2d 76 61 72 20 64 62 20 n db:set-var db
12670 22 44 45 4c 45 54 45 44 5f 54 45 53 54 53 22 20 "DELETED_TESTS"
12680 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
12690 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 6e ))... ;; n
126a0 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 eed to figure ou
126b0 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 t the path to th
126c0 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 e run dir and re
126d0 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 move it if empty
126e0 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 ... ;;
126f0 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 (if (null? (glob
12700 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 22 (conc runpath "
12710 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 20 20 20 /*")))...
12720 3b 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 6e ;; (begin
12730 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 ... ;; . (
12740 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
12750 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 20 emoving run dir
12760 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 20 " runpath)...
12770 20 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d ;; . (system
12780 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 (conc "rmdir -p
12790 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 " runpath))))..
127a0 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 20 . )))))..
127b0 29 29 0a 20 20 20 20 20 72 75 6e 73 29 0a 20 20 )). runs).
127c0 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c (sqlite3:final
127d0 69 7a 65 21 20 74 61 73 6b 73 2d 64 62 29 29 0a ize! tasks-db)).
127e0 20 20 23 74 29 0a 0a 28 64 65 66 69 6e 65 20 28 #t)..(define (
127f0 72 75 6e 73 3a 72 65 6d 6f 76 65 2d 74 65 73 74 runs:remove-test
12800 2d 64 69 72 65 63 74 6f 72 79 20 64 62 20 74 65 -directory db te
12810 73 74 20 72 65 6d 6f 76 65 2d 64 61 74 61 2d 6f st remove-data-o
12820 6e 6c 79 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 nly). (let* ((r
12830 75 6e 2d 64 69 72 20 20 20 20 20 20 20 28 64 62 un-dir (db
12840 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
12850 20 74 65 73 74 29 29 20 20 20 20 3b 3b 20 72 75 test)) ;; ru
12860 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 n dir is from th
12870 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 20 28 72 e link tree.. (r
12880 65 61 6c 2d 64 69 72 20 20 20 20 20 20 28 69 66 eal-dir (if
12890 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 (file-exists? r
128a0 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 28 un-dir).... (
128b0 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 resolve-pathname
128c0 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 run-dir)....
128d0 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 72 #f))). (if r
128e0 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 0a emove-data-only.
128f0 09 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 .(mt:test-set-st
12900 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
12910 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
12920 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 n_id test)(db:te
12930 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
12940 22 43 4c 45 41 4e 49 4e 47 22 20 22 4c 4f 43 4b "CLEANING" "LOCK
12950 45 44 22 20 23 66 29 0a 09 28 6d 74 3a 74 65 73 ED" #f)..(mt:tes
12960 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
12970 75 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 73 us-by-id (db:tes
12980 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 65 73 t-get-run_id tes
12990 74 29 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 t)(db:test-get-i
129a0 64 20 74 65 73 74 29 20 22 52 45 4d 4f 56 49 4e d test) "REMOVIN
129b0 47 22 20 22 4c 4f 43 4b 45 44 22 20 23 66 29 29 G" "LOCKED" #f))
129c0 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
129d0 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 65 6d 70 t-info 1 "Attemp
129e0 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 ting to remove "
129f0 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 28 63 (if real-dir (c
12a00 6f 6e 63 20 22 20 64 69 72 20 22 20 72 65 61 6c onc " dir " real
12a10 2d 64 69 72 20 22 20 61 6e 64 20 22 29 20 22 22 -dir " and ") ""
12a20 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 ) " link " run-d
12a30 69 72 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ir). (if (and
12a40 20 72 65 61 6c 2d 64 69 72 20 0a 09 20 20 20 20 real-dir ..
12a50 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
12a60 74 68 20 72 65 61 6c 2d 64 69 72 29 20 35 29 0a th real-dir) 5).
12a70 09 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 . (file-exis
12a80 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 29 20 3b ts? real-dir)) ;
12a90 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 63 20 ; bad heuristic
12aa0 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 76 65 but should preve
12ab0 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 nt /tmp /home et
12ac0 63 2e 0a 09 28 62 65 67 69 6e 20 3b 3b 20 6c 65 c...(begin ;; le
12ad0 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 72 t* ((realpath (r
12ae0 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 esolve-pathname
12af0 72 75 6e 2d 64 69 72 29 29 29 0a 09 20 20 28 64 run-dir))).. (d
12b00 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
12b10 31 20 22 52 65 63 75 72 73 69 76 65 6c 79 20 72 1 "Recursively r
12b20 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 emoving " real-d
12b30 69 72 29 0a 09 20 20 28 69 66 20 28 66 69 6c 65 ir).. (if (file
12b40 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 -exists? real-di
12b50 72 29 0a 09 20 20 20 20 20 20 28 72 75 6e 73 3a r).. (runs:
12b60 73 61 66 65 2d 64 65 6c 65 74 65 2d 74 65 73 74 safe-delete-test
12b70 2d 64 69 72 20 72 65 61 6c 2d 64 69 72 29 0a 09 -dir real-dir)..
12b80 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
12b90 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 nt 0 "WARNING: t
12ba0 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d 64 est dir " real-d
12bb0 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 ir " appears to
12bc0 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 not exist or is
12bd0 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 29 not readable")))
12be0 0a 09 28 69 66 20 72 65 61 6c 2d 64 69 72 20 0a ..(if real-dir .
12bf0 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
12c00 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 t 0 "WARNING: di
12c10 72 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 rectory " real-d
12c20 69 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 ir " does not ex
12c30 69 73 74 22 29 0a 09 20 20 20 20 28 64 65 62 75 ist").. (debu
12c40 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
12c50 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 64 69 72 65 NG: no real dire
12c60 63 74 6f 72 79 20 63 6f 72 72 6f 73 70 6f 6e 64 ctory corrospond
12c70 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 20 72 75 ing to link " ru
12c80 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 68 69 6e 67 n-dir ", nothing
12c90 20 64 6f 6e 65 22 29 29 29 0a 20 20 20 20 28 69 done"))). (i
12ca0 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b f (symbolic-link
12cb0 3f 20 72 75 6e 2d 64 69 72 29 0a 09 28 62 65 67 ? run-dir)..(beg
12cc0 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
12cd0 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 6d 6f 76 nt-info 1 "Remov
12ce0 69 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 ing symlink " ru
12cf0 6e 2d 64 69 72 29 0a 09 20 20 28 68 61 6e 64 6c n-dir).. (handl
12d00 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 e-exceptions..
12d10 20 65 78 6e 0a 09 20 20 20 28 64 65 62 75 67 3a exn.. (debug:
12d20 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
12d30 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 Failed to remov
12d40 65 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d e symlink " run-
12d50 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d dir ((condition-
12d60 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
12d70 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
12d80 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 exn) ", attempt
12d90 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 ing to continue"
12da0 29 0a 09 20 20 20 28 64 65 6c 65 74 65 2d 66 69 ).. (delete-fi
12db0 6c 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 28 le run-dir)))..(
12dc0 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 if (directory? r
12dd0 75 6e 2d 64 69 72 29 0a 09 20 20 20 20 28 69 66 un-dir).. (if
12de0 20 28 3e 20 28 64 69 72 65 63 74 6f 72 79 2d 66 (> (directory-f
12df0 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 66 20 78 old (lambda (f x
12e00 29 28 2b 20 31 20 78 29 29 20 30 20 72 75 6e 2d )(+ 1 x)) 0 run-
12e10 64 69 72 29 20 30 29 0a 09 09 28 64 65 62 75 67 dir) 0)...(debug
12e20 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
12e30 47 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 G: refusing to r
12e40 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 emove " run-dir
12e50 22 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 65 " as it is not e
12e60 6d 70 74 79 22 29 0a 09 09 28 68 61 6e 64 6c 65 mpty")...(handle
12e70 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 65 -exceptions... e
12e80 78 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 xn... (debug:pri
12e90 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 nt 0 "ERROR: Fa
12ea0 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 64 iled to remove d
12eb0 69 72 65 63 74 6f 72 79 20 22 20 72 75 6e 2d 64 irectory " run-d
12ec0 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 ir ((condition-p
12ed0 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
12ee0 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
12ef0 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 exn) ", attempti
12f00 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 ng to continue")
12f10 0a 09 09 20 28 64 65 6c 65 74 65 2d 64 69 72 65 ... (delete-dire
12f20 63 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 29 ctory run-dir)))
12f30 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 .. (if (and r
12f40 75 6e 2d 64 69 72 0a 09 09 20 20 20 20 20 28 6e un-dir... (n
12f50 6f 74 20 28 6d 65 6d 62 65 72 20 72 75 6e 2d 64 ot (member run-d
12f60 69 72 20 28 6c 69 73 74 20 22 6e 2f 61 22 20 22 ir (list "n/a" "
12f70 2f 74 6d 70 2f 62 61 64 6e 61 6d 65 22 29 29 29 /tmp/badname")))
12f80 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
12f90 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 0 "WARNING: not
12fa0 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e 2d removing " run-
12fb0 64 69 72 20 22 20 61 73 20 69 74 20 65 69 74 68 dir " as it eith
12fc0 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 er doesn't exist
12fd0 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 79 6d or is not a sym
12fe0 6c 69 6e 6b 22 29 0a 09 09 28 64 65 62 75 67 3a link")...(debug:
12ff0 70 72 69 6e 74 20 30 20 22 4e 4f 54 45 3a 20 74 print 0 "NOTE: t
13000 68 65 20 72 75 6e 20 64 69 72 20 66 6f 72 20 74 he run dir for t
13010 68 69 73 20 74 65 73 74 20 69 73 20 75 6e 64 65 his test is unde
13020 66 69 6e 65 64 2e 20 54 65 73 74 20 6d 61 79 20 fined. Test may
13030 68 61 76 65 20 61 6c 72 65 61 64 79 20 62 65 65 have already bee
13040 6e 20 64 65 6c 65 74 65 64 2e 22 29 29 0a 09 20 n deleted."))..
13050 20 20 20 29 29 0a 20 20 20 20 3b 3b 20 4f 6e 6c )). ;; Onl
13060 79 20 64 65 6c 65 74 65 20 74 68 65 20 72 65 63 y delete the rec
13070 6f 72 64 73 20 2a 61 66 74 65 72 2a 20 72 65 6d ords *after* rem
13080 6f 76 69 6e 67 20 74 68 65 20 64 69 72 65 63 74 oving the direct
13090 6f 72 79 2e 20 49 66 20 74 68 69 6e 67 73 20 66 ory. If things f
130a0 61 69 6c 20 77 65 20 68 61 76 65 20 61 20 72 65 ail we have a re
130b0 63 6f 72 64 20 0a 20 20 20 20 28 69 66 20 72 65 cord . (if re
130c0 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 0a 09 move-data-only..
130d0 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 (mt:test-set-sta
130e0 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
130f0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
13100 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 73 _id test)(db:tes
13110 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
13120 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 6e 2f NOT_STARTED" "n/
13130 61 22 20 23 66 29 0a 09 28 72 6d 74 3a 64 65 6c a" #f)..(rmt:del
13140 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ete-test-records
13150 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
13160 6e 5f 69 64 20 74 65 73 74 29 20 28 64 62 3a 74 n_id test) (db:t
13170 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
13180 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
13190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
131a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
131b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
131c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
131d0 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 6d ; Routines for m
131e0 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 6e 73 anipulating runs
131f0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
13200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13220 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13230 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 =========..;; Si
13240 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 74 nce many calls t
13250 6f 20 61 20 72 75 6e 20 72 65 71 75 69 72 65 20 o a run require
13260 70 72 65 74 74 79 20 6d 75 63 68 20 74 68 65 20 pretty much the
13270 73 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 74 same setup .;; t
13280 68 69 73 20 77 72 61 70 70 65 72 20 69 73 20 75 his wrapper is u
13290 73 65 64 20 74 6f 20 72 65 64 75 63 65 20 74 68 sed to reduce th
132a0 65 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f 66 e replication of
132b0 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 67 code.(define (g
132c0 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 eneral-run-call
132d0 73 77 69 74 63 68 6e 61 6d 65 20 61 63 74 69 6f switchname actio
132e0 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 20 28 n-desc proc). (
132f0 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 6f let ((runname (o
13300 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
13310 22 2d 72 75 6e 6e 61 6d 65 22 29 28 61 72 67 73 "-runname")(args
13320 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 :get-arg ":runna
13330 6d 65 22 29 29 29 0a 09 28 74 61 72 67 65 74 20 me")))..(target
13340 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 (common:args-ge
13350 74 2d 74 61 72 67 65 74 29 29 29 0a 20 20 20 20 t-target))).
13360 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 (cond. ((not
13370 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 28 target). (
13380 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
13390 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 RROR: Missing re
133a0 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 quired parameter
133b0 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d for " switchnam
133c0 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 e ", you must sp
133d0 65 63 69 66 79 20 74 68 65 20 74 61 72 67 65 74 ecify the target
133e0 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 29 0a with -target").
133f0 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 0a (exit 3)).
13400 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e 61 ((not runna
13410 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 me). (debug
13420 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
13430 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 Missing require
13440 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 d parameter for
13450 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 " switchname ",
13460 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 you must specify
13470 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 the run name wi
13480 74 68 20 2d 72 75 6e 6e 61 6d 65 20 72 75 6e 6e th -runname runn
13490 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 78 69 ame"). (exi
134a0 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c 73 65 t 3)). (else
134b0 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 62 . (let ((db
134c0 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b 65 79 #f).. (key
134d0 73 20 23 66 29 29 0a 09 28 69 66 20 28 6e 6f 74 s #f))..(if (not
134e0 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 66 (launch:setup-f
134f0 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 20 28 62 or-run)).. (b
13500 65 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 65 egin .. (de
13510 62 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 bug:print 0 "Fai
13520 6c 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 led to setup, ex
13530 69 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 iting").. (
13540 65 78 69 74 20 31 29 29 29 0a 09 3b 3b 20 28 69 exit 1)))..;; (i
13550 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
13560 22 2d 73 65 72 76 65 72 22 29 0a 09 3b 3b 20 20 "-server")..;;
13570 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
13580 75 6e 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 un server:start
13590 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 db (args:get-arg
135a0 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a 09 28 "-server")))..(
135b0 73 65 74 21 20 6b 65 79 73 20 28 6b 65 79 73 3a set! keys (keys:
135c0 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 config-get-field
135d0 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a s *configdat*)).
135e0 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 20 .;; have enough
135f0 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 67 to process -targ
13600 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 68 et or -reqtarg h
13610 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a 67 ere..(if (args:g
13620 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
13630 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 ").. (let* ((
13640 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 runconfigf (conc
13650 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 *toppath* "/ru
13660 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
13670 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 )) ;; DO NOT EVA
13680 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 LUATE ALL ...
13690 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 (runconfig (rea
136a0 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 d-config runconf
136b0 69 67 66 20 23 66 20 23 74 20 65 6e 76 69 72 6f igf #f #t enviro
136c0 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 0a 09 20 n-patt: #f)))..
136d0 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 (if (hash-t
136e0 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
136f0 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 runconfig (args
13700 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
13710 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 rg") #f)... (ke
13720 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
13730 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
13740 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
13750 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 ) args:arg-hash)
13760 0a 09 09 20 20 20 20 0a 09 09 20 20 28 62 65 67 ... ... (beg
13770 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
13780 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
13790 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
137a0 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
137b0 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
137c0 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 unconfigf)...
137d0 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 (if db (sqlite3
137e0 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a :finalize! db)).
137f0 09 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 .. (exit 1)))
13800 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 73 ).. (if (args
13810 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
13820 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 t")...(keys:targ
13830 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 et-set-args keys
13840 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
13850 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 -target" args:ar
13860 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 g-hash) args:arg
13870 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e -hash)))..(if (n
13880 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 ot (car *configi
13890 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 nfo*)).. (beg
138a0 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
138b0 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
138c0 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 Attempted to "
138d0 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 action-desc " bu
138e0 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 t run area confi
138f0 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 g file not found
13900 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
13910 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 1)).. ;; Extr
13920 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 act out stuff ne
13930 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 eded in most or
13940 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 many calls..
13950 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c ;; here then cal
13960 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 l proc.. (let
13970 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 28 * ((keyvals (
13980 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
13990 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
139a0 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 )).. (proc
139b0 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b target runname k
139c0 65 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a 09 eys keyvals)))..
139d0 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
139e0 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
139f0 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 (set! *didsometh
13a00 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b ing* #t))))))..;
13a10 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
13a20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a30 3d 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 0a 3b 3b 20 4c 6f 63 6b 2f =======.;; Lock/
13a60 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d unlock runs.;;==
13a70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13aa0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13ab0 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
13ac0 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 uns:handle-locki
13ad0 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 ng target keys r
13ae0 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f unname lock unlo
13af0 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a ck user). (let*
13b00 20 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a ((db #f).
13b10 09 20 28 72 75 6e 64 61 74 20 20 20 28 6d 74 3a . (rundat (mt:
13b20 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
13b30 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 74 61 keys runname ta
13b40 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 72 rget)).. (header
13b50 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
13b60 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e undat 0)).. (run
13b70 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 s (vector-re
13b80 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 20 f rundat 1))).
13b90 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
13ba0 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 74 bda (run)...(let
13bb0 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 ((run-id (db:ge
13bc0 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
13bd0 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 r run header "id
13be0 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 6f 72 ")))... (if (or
13bf0 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 20 lock.... (and
13c00 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 20 unlock....
13c10 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 72 (begin..... (pr
13c20 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 61 6c int "Do you real
13c30 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f 63 ly wish to unloc
13c40 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 k run " run-id "
13c50 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 09 ?\n y/n: ")...
13c60 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 20 28 .. (equal? "y" (
13c70 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 read-line)))))..
13c80 09 20 20 20 20 20 20 28 72 6d 74 3a 6c 6f 63 6b . (rmt:lock
13c90 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d /unlock-run run-
13ca0 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 id lock unlock u
13cb0 73 65 72 29 0a 09 09 20 20 20 20 20 20 28 64 65 ser)... (de
13cc0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
13cd0 20 22 53 6b 69 70 70 69 6e 67 20 6c 6f 63 6b 2f "Skipping lock/
13ce0 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 6e 2d unlock on " run-
13cf0 69 64 29 29 29 29 0a 09 20 20 20 20 20 20 72 75 id)))).. ru
13d00 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ns))).;;========
13d10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
13d50 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b ; Rollup runs.;;
13d60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13da0 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 61 74 ======..;; Updat
13db0 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 e the test_meta
13dc0 74 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 74 table for this t
13dd0 65 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e est.(define (run
13de0 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 s:update-test_me
13df0 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ta test-name tes
13e00 74 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 t-conf). (let (
13e10 28 63 75 72 72 72 65 63 6f 72 64 20 28 72 6d 74 (currrecord (rmt
13e20 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 :testmeta-get-re
13e30 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 cord test-name))
13e40 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 ). (if (not c
13e50 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 urrrecord)..(beg
13e60 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 in.. (set! curr
13e70 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 record (make-vec
13e80 74 6f 72 20 31 31 20 23 66 29 29 0a 09 20 20 28 tor 11 #f)).. (
13e90 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 rmt:testmeta-add
13ea0 2d 72 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d -record test-nam
13eb0 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 e))). (for-ea
13ec0 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
13ed0 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 6c (key). (l
13ee0 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 20 et* ((idx (cadr
13ef0 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 6c key)).. (fl
13f00 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 20 d (car key))..
13f10 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 (val (confi
13f20 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f g-lookup test-co
13f30 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 66 nf "test_meta" f
13f40 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 ld))).. ;; (debu
13f50 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a 20 g:print 5 "idx:
13f60 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 66 " idx " fld: " f
13f70 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 ld " val: " val)
13f80 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c 20 .. (if (and val
13f90 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 65 (not (equal? (ve
13fa0 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 63 ctor-ref currrec
13fb0 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 0a ord idx) val))).
13fc0 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
13fd0 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 64 (print "Upd
13fe0 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d ating " test-nam
13ff0 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 22 e " " fld " to "
14000 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 72 val).. (r
14010 6d 74 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 mt:testmeta-upda
14020 74 65 2d 66 69 65 6c 64 20 74 65 73 74 2d 6e 61 te-field test-na
14030 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a me fld val))))).
14040 20 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 '(("author"
14050 20 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 2)("owner" 3)("
14060 64 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 description" 4)(
14070 22 72 65 76 69 65 77 65 64 22 20 35 29 28 22 74 "reviewed" 5)("t
14080 61 67 73 22 20 39 29 28 22 6a 6f 62 67 72 6f 75 ags" 9)("jobgrou
14090 70 22 20 31 30 29 29 29 29 29 0a 0a 3b 3b 20 55 p" 10)))))..;; U
140a0 70 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 pdate test_meta
140b0 66 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 for all tests.(d
140c0 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 efine (runs:upda
140d0 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 te-all-test_meta
140e0 20 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 db). (let ((te
140f0 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a st-names (tests:
14100 67 65 74 2d 61 6c 6c 29 29 29 20 3b 3b 20 28 74 get-all))) ;; (t
14110 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 ests:get-valid-t
14120 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 ests))). (for
14130 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
14140 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a bda (test-name).
14150 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
14160 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 6d 74 3a est-conf (mt:
14170 6c 61 7a 79 2d 72 65 61 64 2d 74 65 73 74 2d 63 lazy-read-test-c
14180 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 29 onfig test-name)
14190 29 29 0a 09 20 28 69 66 20 74 65 73 74 2d 63 6f )).. (if test-co
141a0 6e 66 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d nf (runs:update-
141b0 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e test_meta test-n
141c0 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 ame test-conf)))
141d0 29 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 ). (hash-tab
141e0 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 6e 61 6d le-keys test-nam
141f0 65 73 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 es))))..;; This
14200 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 could probably b
14210 65 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 e refactored int
14220 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 o one complex qu
14230 65 72 79 20 2e 2e 2e 0a 3b 3b 20 4e 4f 54 20 50 ery ....;; NOT P
14240 4f 52 54 45 44 20 2d 20 44 4f 20 4e 4f 54 20 55 ORTED - DO NOT U
14250 53 45 20 59 45 54 0a 3b 3b 0a 28 64 65 66 69 6e SE YET.;;.(defin
14260 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 e (runs:rollup-r
14270 75 6e 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 un keys runname
14280 75 73 65 72 20 6b 65 79 76 61 6c 73 29 0a 20 20 user keyvals).
14290 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
142a0 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c runs:rollup-run,
142b0 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 keys: " keys "
142c0 2d 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 -runname " runna
142d0 6d 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 me " user: " use
142e0 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 r). (let* ((db
142f0 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
14300 0a 09 20 3b 3b 20 72 65 67 69 73 74 65 72 20 72 .. ;; register r
14310 75 6e 20 6f 70 65 72 61 74 65 73 20 6f 6e 20 74 un operates on t
14320 68 65 20 6d 61 69 6e 20 64 62 0a 09 20 28 6e 65 he main db.. (ne
14330 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 w-run-id (r
14340 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 mt:register-run
14350 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 keyvals runname
14360 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
14370 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 )).. (prev-tests
14380 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6d (rmt:get-m
14390 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
143a0 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
143b0 73 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 s new-run-id "%"
143c0 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 2d 74 "%")).. (curr-t
143d0 65 73 74 73 20 20 20 20 20 20 28 6d 74 3a 67 65 ests (mt:ge
143e0 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
143f0 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 new-run-id "%/%"
14400 20 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 '() '())).. (cu
14410 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d rr-tests-hash (m
14420 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
14430 29 0a 20 20 20 20 28 72 6d 74 3a 75 70 64 61 74 ). (rmt:updat
14440 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 e-run-event_time
14450 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 new-run-id).
14460 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c ;; index the al
14470 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 ready saved test
14480 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e s by testname an
14490 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 d itemdat in cur
144a0 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 r-tests-hash.
144b0 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
144c0 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 (lambda (testdat
144d0 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
144e0 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 (testname (db:t
144f0 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
14500 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
14510 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 (item-path (db
14520 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
14530 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
14540 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
14550 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 (conc testname "
14560 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a /" item-path))).
14570 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
14580 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
14590 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 sh full-name tes
145a0 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 tdat))). cur
145b0 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 r-tests). ;;
145c0 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 NOPE: Non-optima
145d0 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 l approach. Try
145e0 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 this instead..
145f0 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 ;; 1. tests
14600 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 are received in
14610 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 a list, most rec
14620 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b ent first. ;;
14630 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 2. replace th
14640 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 e rollup test wi
14650 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 th the new *alwa
14660 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ys*. (for-eac
14670 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
14680 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 (testdat).
14690 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d (let* ((testnam
146a0 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d e (db:test-get-
146b0 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
146c0 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d )).. (item-
146d0 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 path (db:test-ge
146e0 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
146f0 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 dat)).. (fu
14700 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 ll-name (conc te
14710 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
14720 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 path)).. (p
14730 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 rev-test-dat (ha
14740 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
14750 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d ault curr-tests-
14760 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 hash full-name #
14770 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
14780 2d 73 74 65 70 73 20 20 20 20 28 72 6d 74 3a 67 -steps (rmt:g
14790 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
147a0 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 t (db:test-get-i
147b0 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
147c0 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 (new-test-re
147d0 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 cord #f)).. ;; r
147e0 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 eplace these wit
147f0 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c h insert ... sel
14800 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c ect.. (apply sql
14810 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 ite3:execute ...
14820 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 db ...(conc "INS
14830 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
14840 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 NTO tests (run_i
14850 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 d,testname,state
14860 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
14870 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c me,host,cpuload,
14880 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 diskfree,uname,r
14890 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c undir,item_path,
148a0 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e run_duration,fin
148b0 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 al_logf,comment)
148c0 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 "... "VALU
148d0 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ES (?,?,?,?,?,?,
148e0 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 ?,?,?,?,?,?,?,?)
148f0 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 ;")...new-run-id
14900 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e (cddr (vector->
14910 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a list testdat))).
14920 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 . (set! new-test
14930 64 61 74 20 28 63 61 72 20 28 6d 74 3a 67 65 74 dat (car (mt:get
14940 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e -tests-for-run n
14950 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 ew-run-id (conc
14960 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
14970 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 29 m-path) '() '())
14980 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 )).. (hash-table
14990 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 -set! curr-tests
149a0 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
149b0 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 new-testdat) ;;
149c0 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f this could be co
149d0 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 nfusing, which r
149e0 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 ecord should go
149f0 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 into the lookup
14a00 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 table?.. ;; Now
14a10 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
14a20 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 st steps.. (debu
14a30 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
14a40 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
14a50 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 st_steps from te
14a60 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
14a70 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
14a80 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
14a90 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
14aa0 64 61 74 29 29 0a 09 20 28 63 64 62 3a 72 65 6d dat)).. (cdb:rem
14ab0 6f 74 65 2d 72 75 6e 20 0a 09 20 20 28 6c 61 6d ote-run .. (lam
14ac0 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c bda ().. (sql
14ad0 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
14ae0 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 db .. (c
14af0 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
14b00 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
14b10 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c _steps (test_id,
14b20 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 stepname,state,s
14b30 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
14b40 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
14b50 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 "SELECT " (db:t
14b60 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
14b70 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 estdat) ",stepna
14b80 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
14b90 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 event_time,comme
14ba0 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 nt FROM test_ste
14bb0 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 ps WHERE test_id
14bc0 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a =?;").. (db:
14bd0 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
14be0 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f dat)).. ;; No
14bf0 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
14c00 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 test data.. (
14c10 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 debug:print 4 "C
14c20 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 opying records i
14c30 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d n test_data from
14c40 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 test_id=" (db:t
14c50 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
14c60 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 at) " to " (db:t
14c70 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
14c80 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 estdat)).. (s
14c90 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
14ca0 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 . db ..
14cb0 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
14cc0 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
14cd0 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 st_data (test_id
14ce0 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
14cf0 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
14d00 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
14d10 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
14d20 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
14d30 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
14d40 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 t) ",category,va
14d50 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
14d60 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
14d70 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
14d80 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 73 t_data WHERE tes
14d90 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 t_id=?;")..
14da0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
14db0 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 testdat)))).. ))
14dc0 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 . prev-tests
14dd0 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ))).. . .