0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 28 64 uses server)).(d
02b0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 29 eclare (uses mt)
02c0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
02d0: 20 61 72 63 68 69 76 65 29 29 0a 3b 3b 20 28 64 archive)).;; (d
02e0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 66 69 6c eclare (uses fil
02f0: 65 64 62 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 edb))..(include
0300: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0310: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0320: 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 key_records.scm"
0330: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0340: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0350: 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 clude "run_recor
0360: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0370: 65 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e e "test_records.
0380: 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 scm")..(define (
0390: 72 75 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 runs:test-get-fu
03a0: 6c 6c 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 ll-path test).
03b0: 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
03c0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
03d0: 73 74 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a stname test)).
03e0: 09 20 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a . (itempath (db:
03f0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
0400: 74 68 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 th test))). (
0410: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 conc testname (i
0420: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 f (equal? itempa
0430: 74 68 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 th "") "" (conc
0440: 22 28 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 "(" itempath ")"
0450: 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 )))))..;; This i
0460: 73 20 74 68 65 20 2a 6e 65 77 2a 20 6d 65 74 68 s the *new* meth
0470: 6f 64 6f 6c 6f 67 79 2e 20 4f 6e 65 20 72 65 63 odology. One rec
0480: 6f 72 64 20 74 6f 20 69 6e 66 6f 72 6d 20 74 68 ord to inform th
0490: 65 6d 20 61 6e 64 20 69 6e 20 74 68 65 20 63 68 em and in the ch
04a0: 61 6f 73 2c 20 6f 72 67 61 6e 69 73 65 20 74 68 aos, organise th
04b0: 65 6d 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 em..;;.(define (
04c0: 72 75 6e 73 3a 63 72 65 61 74 65 2d 72 75 6e 2d runs:create-run-
04d0: 72 65 63 6f 72 64 29 0a 20 20 28 6c 65 74 2a 20 record). (let*
04e0: 28 28 6d 63 6f 6e 66 69 67 20 20 20 20 20 20 28 ((mconfig (
04f0: 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 if *configdat*..
0500: 09 20 20 20 20 20 20 20 20 20 20 20 2a 63 6f 6e . *con
0510: 66 69 67 64 61 74 2a 0a 09 09 20 20 20 20 20 20 figdat*...
0520: 20 20 20 20 20 28 69 66 20 28 6c 61 75 6e 63 68 (if (launch
0530: 3a 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 0a :setup-for-run).
0540: 09 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
0550: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 09 20 *configdat*...
0560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
0570: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 20 20 egin...
0580: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
0590: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 rint 0 "ERROR: C
05a0: 61 6c 6c 65 64 20 73 65 74 75 70 20 69 6e 20 61 alled setup in a
05b0: 20 6e 6f 6e 2d 6d 65 67 61 74 65 73 74 20 61 72 non-megatest ar
05c0: 65 61 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 09 ea, exiting")...
05d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
05e0: 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 20 (exit 1)))))..
05f0: 20 28 72 75 6e 72 65 63 20 20 20 20 20 20 28 72 (runrec (r
0600: 75 6e 73 3a 72 75 6e 72 65 63 2d 6d 61 6b 65 2d uns:runrec-make-
0610: 72 65 63 6f 72 64 29 29 0a 09 20 20 28 74 61 72 record)).. (tar
0620: 67 65 74 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e get (common
0630: 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 :args-get-target
0640: 29 29 0a 09 20 20 28 72 75 6e 6e 61 6d 65 20 20 )).. (runname
0650: 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 (or (args:get
0660: 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 -arg "-runname")
0670: 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 28 61 ... (a
0680: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
0690: 6e 6e 61 6d 65 22 29 29 29 0a 09 20 20 28 74 65 nname"))).. (te
06a0: 73 74 70 61 74 74 20 20 20 20 28 6f 72 20 28 61 stpatt (or (a
06b0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 rgs:get-arg "-te
06c0: 73 74 70 61 74 74 22 29 0a 09 09 20 20 20 20 20 stpatt")...
06d0: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
06e0: 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 arg "-runtests")
06f0: 29 29 0a 09 20 20 28 6b 65 79 73 20 20 20 20 20 )).. (keys
0700: 20 20 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d (keys:config-
0710: 67 65 74 2d 66 69 65 6c 64 73 20 6d 63 6f 6e 66 get-fields mconf
0720: 69 67 29 29 0a 09 20 20 28 6b 65 79 76 61 6c 73 ig)).. (keyvals
0730: 20 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 (keys:targe
0740: 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 t->keyval keys t
0750: 61 72 67 65 74 29 29 0a 09 20 20 28 74 6f 70 70 arget)).. (topp
0760: 61 74 68 20 20 20 20 20 2a 74 6f 70 70 61 74 68 ath *toppath
0770: 2a 29 0a 09 20 20 28 65 6e 76 64 61 74 20 20 20 *).. (envdat
0780: 20 20 20 6b 65 79 76 61 6c 73 29 20 3b 3b 20 69 keyvals) ;; i
0790: 6e 69 74 69 61 6c 20 76 61 6c 75 65 73 20 73 74 nitial values st
07a0: 61 72 74 20 77 69 74 68 20 6b 65 79 76 61 6c 73 art with keyvals
07b0: 0a 09 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 .. (runconfig
07c0: 20 23 66 29 0a 09 20 20 28 73 65 72 76 65 72 64 #f).. (serverd
07d0: 61 74 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 at (if (args:g
07e0: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
07f0: 29 0a 09 09 09 20 20 20 2a 72 75 6e 72 65 6d 6f ).... *runremo
0800: 74 65 2a 0a 09 09 09 20 20 20 23 66 29 29 20 3b te*.... #f)) ;
0810: 3b 20 74 6f 20 62 65 20 75 73 65 64 20 6c 61 74 ; to be used lat
0820: 65 72 0a 09 20 20 28 74 72 61 6e 73 70 6f 72 74 er.. (transport
0830: 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 (or (args:get
0840: 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 6f 72 74 -arg "-transport
0850: 22 29 20 27 68 74 74 70 29 29 0a 09 20 20 28 72 ") 'http)).. (r
0860: 75 6e 2d 69 64 20 20 20 20 20 20 23 66 29 29 0a un-id #f)).
0870: 20 20 20 20 3b 3b 20 53 65 74 20 61 6c 6c 20 74 ;; Set all t
0880: 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 he environment v
0890: 61 72 73 20 77 65 20 6b 6e 6f 77 20 73 6f 20 66 ars we know so f
08a0: 61 72 2c 20 73 74 61 72 74 20 77 69 74 68 20 6b ar, start with k
08b0: 65 79 73 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 eys. (for-eac
08c0: 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 h (lambda (keyva
08d0: 6c 29 0a 09 09 28 73 65 74 65 6e 76 20 28 63 61 l)...(setenv (ca
08e0: 72 20 6b 65 79 76 61 6c 29 28 63 61 64 72 20 6b r keyval)(cadr k
08f0: 65 79 76 61 6c 29 29 29 0a 09 20 20 20 20 20 20 eyval)))..
0900: 6b 65 79 76 61 6c 73 29 0a 20 20 20 20 3b 3b 20 keyvals). ;;
0910: 53 65 74 20 75 70 20 76 61 72 69 6f 75 73 20 61 Set up various a
0920: 6e 64 20 73 75 6e 64 72 79 20 6b 6e 6f 77 6e 20 nd sundry known
0930: 76 61 72 73 20 68 65 72 65 0a 20 20 20 20 28 73 vars here. (s
0940: 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 etenv "MT_RUN_AR
0950: 45 41 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 EA_HOME" toppath
0960: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
0970: 54 5f 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 T_RUNNAME" runna
0980: 6d 65 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 me). (setenv
0990: 22 4d 54 5f 54 41 52 47 45 54 22 20 20 74 61 72 "MT_TARGET" tar
09a0: 67 65 74 29 0a 20 20 20 20 28 73 65 74 65 6e 76 get). (setenv
09b0: 20 22 4d 54 5f 54 45 53 54 53 55 49 54 45 4e 41 "MT_TESTSUITENA
09c0: 4d 45 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ME" (common:get-
09d0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 testsuite-name))
09e0: 0a 20 20 20 20 28 73 65 74 21 20 65 6e 76 64 61 . (set! envda
09f0: 74 20 28 61 70 70 65 6e 64 20 0a 09 09 20 20 65 t (append ... e
0a00: 6e 76 64 61 74 0a 09 09 20 20 28 6c 69 73 74 20 nvdat... (list
0a10: 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 5f 41 52 (list "MT_RUN_AR
0a20: 45 41 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 EA_HOME" toppath
0a30: 29 0a 09 09 09 28 6c 69 73 74 20 22 4d 54 5f 52 )....(list "MT_R
0a40: 55 4e 4e 41 4d 45 22 20 20 20 20 20 20 20 72 75 UNNAME" ru
0a50: 6e 6e 61 6d 65 29 0a 09 09 09 28 6c 69 73 74 20 nname)....(list
0a60: 22 4d 54 5f 54 41 52 47 45 54 22 20 20 20 20 20 "MT_TARGET"
0a70: 20 20 20 74 61 72 67 65 74 29 29 29 29 0a 20 20 target)))).
0a80: 20 20 3b 3b 20 4e 6f 77 20 63 61 6e 20 72 65 61 ;; Now can rea
0a90: 64 20 74 68 65 20 72 75 6e 63 6f 6e 66 69 67 73 d the runconfigs
0aa0: 20 66 69 6c 65 0a 20 20 20 20 3b 3b 20 0a 20 20 file. ;; .
0ab0: 20 20 28 73 65 74 21 20 72 75 6e 63 6f 6e 66 69 (set! runconfi
0ac0: 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 g (read-config (
0ad0: 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 conc *toppath*
0ae0: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
0af0: 66 69 67 22 29 20 23 66 20 23 74 20 73 65 63 74 fig") #f #t sect
0b00: 69 6f 6e 73 3a 20 28 6c 69 73 74 20 22 64 65 66 ions: (list "def
0b10: 61 75 6c 74 22 20 74 61 72 67 65 74 29 29 29 0a ault" target))).
0b20: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
0b30: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0b40: 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 ault runconfig (
0b50: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
0b60: 65 71 74 61 72 67 22 29 20 23 66 29 29 0a 09 28 eqtarg") #f))..(
0b70: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
0b80: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
0b90: 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
0ba0: 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
0bb0: 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
0bc0: 75 6e 63 6f 6e 66 69 67 66 29 0a 09 20 20 28 69 unconfigf).. (i
0bd0: 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 f db (sqlite3:fi
0be0: 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 20 20 nalize! db))..
0bf0: 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 3b (exit 1))). ;
0c00: 3b 20 4e 6f 77 20 68 61 76 65 20 72 75 6e 63 6f ; Now have runco
0c10: 6e 66 69 67 73 20 64 61 74 61 20 6c 6f 61 64 65 nfigs data loade
0c20: 64 2c 20 73 65 74 20 65 6e 76 69 72 6f 6e 6d 65 d, set environme
0c30: 6e 74 20 76 61 72 73 0a 20 20 20 20 28 66 6f 72 nt vars. (for
0c40: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 -each (lambda (s
0c50: 65 63 74 69 6f 6e 29 0a 09 09 28 66 6f 72 2d 65 ection)...(for-e
0c60: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 ach (lambda (var
0c70: 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 val).... (set
0c80: 21 20 65 6e 76 64 61 74 20 28 61 70 70 65 6e 64 ! envdat (append
0c90: 20 65 6e 76 64 61 74 20 28 6c 69 73 74 20 76 61 envdat (list va
0ca0: 72 76 61 6c 29 29 29 0a 09 09 09 20 20 20 20 28 rval))).... (
0cb0: 73 61 66 65 2d 73 65 74 65 6e 76 20 28 63 61 72 safe-setenv (car
0cc0: 20 76 61 72 76 61 6c 29 28 63 61 64 72 20 76 61 varval)(cadr va
0cd0: 72 76 61 6c 29 29 29 0a 09 09 09 20 20 28 63 6f rval))).... (co
0ce0: 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f nfigf:get-sectio
0cf0: 6e 20 72 75 6e 63 6f 6e 66 69 67 20 73 65 63 74 n runconfig sect
0d00: 69 6f 6e 29 29 29 0a 09 20 20 20 20 20 20 28 6c ion))).. (l
0d10: 69 73 74 20 22 64 65 66 61 75 6c 74 22 20 74 61 ist "default" ta
0d20: 72 67 65 74 29 29 0a 20 20 20 20 28 76 65 63 74 rget)). (vect
0d30: 6f 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d or target runnam
0d40: 65 20 74 65 73 74 70 61 74 74 20 6b 65 79 73 20 e testpatt keys
0d50: 6b 65 79 76 61 6c 73 20 65 6e 76 64 61 74 20 6d keyvals envdat m
0d60: 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 config runconfig
0d70: 20 73 65 72 76 65 72 64 61 74 20 74 72 61 6e 73 serverdat trans
0d80: 70 6f 72 74 20 64 62 20 74 6f 70 70 61 74 68 20 port db toppath
0d90: 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 run-id)))..(defi
0da0: 6e 65 20 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 ne (runs:set-meg
0db0: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 atest-env-vars r
0dc0: 75 6e 2d 69 64 20 23 21 6b 65 79 20 28 69 6e 6b un-id #!key (ink
0dd0: 65 79 73 20 23 66 29 28 69 6e 72 75 6e 6e 61 6d eys #f)(inrunnam
0de0: 65 20 23 66 29 28 69 6e 6b 65 79 76 61 6c 73 20 e #f)(inkeyvals
0df0: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 #f)). (let* ((t
0e00: 61 72 67 65 74 20 20 20 20 28 6f 72 20 28 63 6f arget (or (co
0e10: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 mmon:args-get-ta
0e20: 72 67 65 74 29 0a 09 09 09 28 67 65 74 2d 65 6e rget)....(get-en
0e30: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
0e40: 6c 65 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 le "MT_TARGET"))
0e50: 29 0a 09 20 28 6b 65 79 73 20 20 20 20 28 69 66 ).. (keys (if
0e60: 20 69 6e 6b 65 79 73 20 20 20 20 69 6e 6b 65 79 inkeys inkey
0e70: 73 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 s (rmt:get-ke
0e80: 79 73 29 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 ys))).. (keyvals
0e90: 20 20 20 28 69 66 20 69 6e 6b 65 79 76 61 6c 73 (if inkeyvals
0ea0: 20 69 6e 6b 65 79 76 61 6c 73 20 28 6b 65 79 73 inkeyvals (keys
0eb0: 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
0ec0: 6b 65 79 73 20 74 61 72 67 65 74 29 29 29 0a 09 keys target)))..
0ed0: 20 28 76 61 6c 73 20 20 20 20 20 20 28 68 61 73 (vals (has
0ee0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
0ef0: 75 6c 74 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 ult *env-vars-by
0f00: 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 -run-id* run-id
0f10: 23 66 29 29 0a 09 20 28 6c 69 6e 6b 2d 74 72 65 #f)).. (link-tre
0f20: 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 e (configf:looku
0f30: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
0f40: 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 etup" "linktree"
0f50: 29 29 29 0a 20 20 20 20 3b 3b 20 67 65 74 20 74 ))). ;; get t
0f60: 68 65 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 he info from the
0f70: 20 64 62 20 61 6e 64 20 70 75 74 20 69 74 20 69 db and put it i
0f80: 6e 20 74 68 65 20 63 61 63 68 65 0a 20 20 20 20 n the cache.
0f90: 28 69 66 20 6c 69 6e 6b 2d 74 72 65 65 0a 09 28 (if link-tree..(
0fa0: 73 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 setenv "MT_LINKT
0fb0: 52 45 45 22 20 6c 69 6e 6b 2d 74 72 65 65 29 0a REE" link-tree).
0fc0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
0fd0: 22 45 52 52 4f 52 3a 20 6c 69 6e 6b 74 72 65 65 "ERROR: linktree
0fe0: 20 6e 6f 74 20 73 65 74 2c 20 73 68 6f 75 6c 64 not set, should
0ff0: 20 62 65 20 73 65 74 20 69 6e 20 6d 65 67 61 74 be set in megat
1000: 65 73 74 2e 63 6f 6e 66 69 67 20 69 6e 20 5b 73 est.config in [s
1010: 65 74 75 70 5d 20 73 65 63 74 69 6f 6e 2e 22 29 etup] section.")
1020: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 76 ). (if (not v
1030: 61 6c 73 29 0a 09 28 6c 65 74 20 28 28 68 74 20 als)..(let ((ht
1040: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1050: 29 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 ))).. (hash-tab
1060: 6c 65 2d 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 le-set! *env-var
1070: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e s-by-run-id* run
1080: 2d 69 64 20 68 74 29 0a 09 20 20 28 73 65 74 21 -id ht).. (set!
1090: 20 76 61 6c 73 20 68 74 29 0a 09 20 20 28 66 6f vals ht).. (fo
10a0: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
10b0: 64 61 20 28 6b 65 79 29 0a 09 20 20 20 20 20 28 da (key).. (
10c0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
10d0: 76 61 6c 73 20 28 63 61 72 20 6b 65 79 29 20 28 vals (car key) (
10e0: 63 61 64 72 20 6b 65 79 29 29 29 0a 09 20 20 20 cadr key)))..
10f0: 6b 65 79 76 61 6c 73 29 29 29 0a 20 20 20 20 3b keyvals))). ;
1100: 3b 20 66 72 6f 6d 20 74 68 65 20 63 61 63 68 65 ; from the cache
1110: 64 20 64 61 74 61 20 73 65 74 20 74 68 65 20 76 d data set the v
1120: 61 72 73 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ars. (hash-ta
1130: 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 ble-for-each.
1140: 20 20 76 61 6c 73 0a 20 20 20 20 20 28 6c 61 6d vals. (lam
1150: 62 64 61 20 28 6b 65 79 20 76 61 6c 29 0a 20 20 bda (key val).
1160: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1170: 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 6b 65 t 2 "setenv " ke
1180: 79 20 22 20 22 20 76 61 6c 29 0a 20 20 20 20 20 y " " val).
1190: 20 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 6b (safe-setenv k
11a0: 65 79 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 ey val))). (i
11b0: 66 20 28 6e 6f 74 20 28 67 65 74 2d 65 6e 76 69 f (not (get-envi
11c0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
11d0: 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 28 73 "MT_TARGET"))(s
11e0: 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 etenv "MT_TARGET
11f0: 22 20 74 61 72 67 65 74 29 29 0a 20 20 20 20 28 " target)). (
1200: 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 alist->env-vars
1210: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1220: 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 64 default *configd
1230: 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 at* "env-overrid
1240: 65 22 20 27 28 29 29 29 0a 20 20 20 20 3b 3b 20 e" '())). ;;
1250: 4c 65 74 73 20 75 73 65 20 74 68 69 73 20 61 73 Lets use this as
1260: 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 an opportunity
1270: 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e 4e 41 4d to put MT_RUNNAM
1280: 45 20 69 6e 20 74 68 65 20 65 6e 76 69 72 6f 6e E in the environ
1290: 6d 65 6e 74 0a 20 20 20 20 28 6c 65 74 20 28 28 ment. (let ((
12a0: 72 75 6e 6e 61 6d 65 20 20 28 69 66 20 69 6e 72 runname (if inr
12b0: 75 6e 6e 61 6d 65 20 69 6e 72 75 6e 6e 61 6d 65 unname inrunname
12c0: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e 61 (rmt:get-run-na
12d0: 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 me-from-id run-i
12e0: 64 29 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 d)))). (if
12f0: 72 75 6e 6e 61 6d 65 0a 09 20 20 28 73 65 74 65 runname.. (sete
1300: 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 nv "MT_RUNNAME"
1310: 72 75 6e 6e 61 6d 65 29 0a 09 20 20 28 64 65 62 runname).. (deb
1320: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
1330: 52 3a 20 6e 6f 20 76 61 6c 75 65 20 66 6f 72 20 R: no value for
1340: 72 75 6e 6e 61 6d 65 20 66 6f 72 20 69 64 20 22 runname for id "
1350: 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 run-id))). (
1360: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 setenv "MT_RUN_A
1370: 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 61 REA_HOME" *toppa
1380: 74 68 2a 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 th*)))..(define
1390: 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 (set-item-env-va
13a0: 72 73 20 69 74 65 6d 64 61 74 29 0a 20 20 28 66 rs itemdat). (f
13b0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
13c0: 28 69 74 65 6d 29 0a 09 20 20 20 20 20 20 28 64 (item).. (d
13d0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 ebug:print 2 "se
13e0: 74 65 6e 76 20 22 20 28 63 61 72 20 69 74 65 6d tenv " (car item
13f0: 29 20 22 20 22 20 28 63 61 64 72 20 69 74 65 6d ) " " (cadr item
1400: 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 65 6e )).. (seten
1410: 76 20 28 63 61 72 20 69 74 65 6d 29 20 28 63 61 v (car item) (ca
1420: 64 72 20 69 74 65 6d 29 29 29 0a 09 20 20 20 20 dr item)))..
1430: 69 74 65 6d 64 61 74 29 29 0a 0a 3b 3b 20 45 76 itemdat))..;; Ev
1440: 65 72 79 20 74 69 6d 65 20 63 61 6e 2d 72 75 6e ery time can-run
1450: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 69 73 20 63 -more-tests is c
1460: 61 6c 6c 65 64 20 69 6e 63 72 65 6d 65 6e 74 20 alled increment
1470: 74 68 65 20 64 65 6c 61 79 0a 3b 3b 0a 3b 3b 20 the delay.;;.;;
1480: 4e 4f 54 45 3a 20 57 65 20 72 75 6e 20 74 68 69 NOTE: We run thi
1490: 73 20 73 65 72 76 65 72 2d 73 69 64 65 21 21 20 s server-side!!
14a0: 44 6f 20 6e 6f 74 20 75 73 65 20 74 68 69 73 20 Do not use this
14b0: 67 6c 6f 62 61 6c 20 65 78 63 65 70 74 20 69 6e global except in
14c0: 20 74 68 65 20 72 75 6e 73 3a 63 61 6e 2d 72 75 the runs:can-ru
14d0: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 6f 75 n-more-tests rou
14e0: 74 69 6e 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 tine.;;.(define
14f0: 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e *last-num-runnin
1500: 67 2d 74 65 73 74 73 2a 20 30 29 0a 28 64 65 66 g-tests* 0).(def
1510: 69 6e 65 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 ine *runs:can-ru
1520: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 n-more-tests-cou
1530: 6e 74 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 28 nt* 0).(define (
1540: 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d runs:shrink-can-
1550: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1560: 6f 75 6e 74 29 0a 20 20 28 73 65 74 21 20 2a 72 ount). (set! *r
1570: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
1580: 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 -tests-count* 0)
1590: 29 20 3b 3b 20 28 2f 20 2a 72 75 6e 73 3a 63 61 ) ;; (/ *runs:ca
15a0: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
15b0: 2d 63 6f 75 6e 74 2a 20 32 29 29 29 0a 0a 3b 3b -count* 2)))..;;
15c0: 20 54 65 6d 70 6f 72 61 72 79 20 67 6c 6f 62 61 Temporary globa
15d0: 6c 73 2e 20 4d 6f 76 65 20 74 68 65 73 65 20 69 ls. Move these i
15e0: 6e 74 6f 20 74 68 65 20 6c 6f 67 69 63 20 6f 72 nto the logic or
15f0: 20 69 6e 74 6f 20 63 6f 6d 6d 6f 6e 0a 3b 3b 0a into common.;;.
1600: 28 64 65 66 69 6e 65 20 2a 73 65 65 6e 2d 63 61 (define *seen-ca
1610: 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 28 6d nt-run-tests* (m
1620: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1630: 20 3b 3b 20 75 73 65 20 74 6f 20 74 72 61 63 6b ;; use to track
1640: 20 74 65 73 74 73 20 74 68 61 74 20 77 65 20 73 tests that we s
1650: 75 73 70 65 63 74 20 63 61 6e 6e 6f 74 20 62 65 uspect cannot be
1660: 20 72 75 6e 0a 28 64 65 66 69 6e 65 20 28 72 75 run.(define (ru
1670: 6e 73 3a 69 6e 63 2d 63 61 6e 74 2d 72 75 6e 2d ns:inc-cant-run-
1680: 74 65 73 74 73 20 74 65 73 74 6e 61 6d 65 29 0a tests testname).
1690: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
16a0: 74 21 20 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 t! *seen-cant-ru
16b0: 6e 2d 74 65 73 74 73 2a 20 74 65 73 74 6e 61 6d n-tests* testnam
16c0: 65 0a 09 09 20 20 20 28 2b 20 28 68 61 73 68 2d e... (+ (hash-
16d0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
16e0: 74 20 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e t *seen-cant-run
16f0: 2d 74 65 73 74 73 2a 20 74 65 73 74 6e 61 6d 65 -tests* testname
1700: 20 30 29 20 31 29 29 29 0a 0a 28 64 65 66 69 6e 0) 1)))..(defin
1710: 65 20 28 72 75 6e 73 3a 63 61 6e 2d 6b 65 65 70 e (runs:can-keep
1720: 2d 72 75 6e 6e 69 6e 67 3f 20 74 65 73 74 6e 61 -running? testna
1730: 6d 65 20 6e 29 0a 20 20 28 3c 20 28 68 61 73 68 me n). (< (hash
1740: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1750: 6c 74 20 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 lt *seen-cant-ru
1760: 6e 2d 74 65 73 74 73 2a 20 74 65 73 74 6e 61 6d n-tests* testnam
1770: 65 20 30 29 20 6e 29 29 0a 0a 28 64 65 66 69 6e e 0) n))..(defin
1780: 65 20 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 65 2a e *runs:denoise*
1790: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
17a0: 65 29 29 20 3b 3b 20 6b 65 79 20 3d 3e 20 6c 61 e)) ;; key => la
17b0: 73 74 2d 74 69 6d 65 2d 72 61 6e 0a 0a 28 64 65 st-time-ran..(de
17c0: 66 69 6e 65 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f fine (runs:lowno
17d0: 69 73 65 20 6b 65 79 20 77 61 69 74 76 61 6c 29 ise key waitval)
17e0: 0a 20 20 28 6c 65 74 20 28 28 6c 61 73 74 74 69 . (let ((lastti
17f0: 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 me (hash-table-r
1800: 65 66 2f 64 65 66 61 75 6c 74 20 2a 72 75 6e 73 ef/default *runs
1810: 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 79 20 30 29 :denoise* key 0)
1820: 29 0a 09 28 63 75 72 72 74 69 6d 65 20 28 63 75 )..(currtime (cu
1830: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
1840: 0a 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 63 . (if (> (- c
1850: 75 72 72 74 69 6d 65 20 6c 61 73 74 74 69 6d 65 urrtime lasttime
1860: 29 20 77 61 69 74 76 61 6c 29 0a 09 28 62 65 67 ) waitval)..(beg
1870: 69 6e 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c in.. (hash-tabl
1880: 65 2d 73 65 74 21 20 2a 72 75 6e 73 3a 64 65 6e e-set! *runs:den
1890: 6f 69 73 65 2a 20 6b 65 79 20 63 75 72 72 74 69 oise* key currti
18a0: 6d 65 29 0a 09 20 20 23 74 29 0a 09 23 66 29 29 me).. #t)..#f))
18b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
18c0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
18d0: 73 74 73 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 sts run-id jobgr
18e0: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
18f0: 6e 74 2d 6a 6f 62 73 29 0a 20 20 28 74 68 72 65 nt-jobs). (thre
1900: 61 64 2d 73 6c 65 65 70 21 20 28 63 6f 6e 64 0a ad-sleep! (cond.
1910: 20 20 20 20 20 20 20 20 09 20 20 28 28 3e 20 2a . ((> *
1920: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
1930: 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 32 e-tests-count* 2
1940: 30 29 0a 09 09 20 20 20 28 69 66 20 28 72 75 6e 0)... (if (run
1950: 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 77 61 69 74 s:lownoise "wait
1960: 69 6e 67 20 6f 6e 20 74 61 73 6b 73 22 20 36 30 ing on tasks" 60
1970: 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 )... (debu
1980: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
1990: 77 61 69 74 69 6e 67 20 66 6f 72 20 74 61 73 6b waiting for task
19a0: 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 2c 20 73 s to complete, s
19b0: 6c 65 65 70 69 6e 67 20 62 72 69 65 66 6c 79 20 leeping briefly
19c0: 2e 2e 2e 22 29 29 0a 09 09 20 20 20 32 29 3b 3b ..."))... 2);;
19d0: 20 6f 62 76 69 6f 75 73 6c 79 20 68 61 76 65 6e obviously haven
19e0: 27 74 20 68 61 64 20 61 6e 79 20 77 6f 72 6b 20 't had any work
19f0: 74 6f 20 64 6f 20 66 6f 72 20 61 20 77 68 69 6c to do for a whil
1a00: 65 0a 20 20 20 20 20 20 20 20 09 20 20 28 65 6c e. . (el
1a10: 73 65 20 30 29 29 29 0a 20 20 28 6c 65 74 2a 20 se 0))). (let*
1a20: 28 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 ((num-running
1a30: 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 (rmt:g
1a40: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
1a50: 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 29 0a unning run-id)).
1a60: 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 . (num-running-i
1a70: 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 72 6d 74 3a n-jobgroup (rmt:
1a80: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
1a90: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
1aa0: 6f 75 70 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 oup run-id jobgr
1ab0: 6f 75 70 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f oup)).. (job-gro
1ac0: 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 up-limit
1ad0: 20 28 6c 65 74 20 28 28 6a 6f 62 67 2d 63 6f 75 (let ((jobg-cou
1ae0: 6e 74 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 nt (config-looku
1af0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
1b00: 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f obgroups" jobgro
1b10: 75 70 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 up)))..... (i
1b20: 66 20 28 73 74 72 69 6e 67 3f 20 6a 6f 62 67 2d f (string? jobg-
1b30: 63 6f 75 6e 74 29 0a 09 09 09 09 09 28 73 74 72 count)......(str
1b40: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6a 6f 62 67 ing->number jobg
1b50: 2d 63 6f 75 6e 74 29 0a 09 09 09 09 09 6a 6f 62 -count)......job
1b60: 67 2d 63 6f 75 6e 74 29 29 29 29 0a 20 20 20 20 g-count)))).
1b70: 28 69 66 20 28 3e 20 28 2b 20 6e 75 6d 2d 72 75 (if (> (+ num-ru
1b80: 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e nning num-runnin
1b90: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 29 20 30 g-in-jobgroup) 0
1ba0: 29 0a 09 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 )..(set! *runs:c
1bb0: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
1bc0: 73 2d 63 6f 75 6e 74 2a 20 28 2b 20 2a 72 75 6e s-count* (+ *run
1bd0: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
1be0: 65 73 74 73 2d 63 6f 75 6e 74 2a 20 31 29 29 29 ests-count* 1)))
1bf0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
1c00: 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e q? *last-num-run
1c10: 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d ning-tests* num-
1c20: 72 75 6e 6e 69 6e 67 29 29 0a 09 28 62 65 67 69 running))..(begi
1c30: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
1c40: 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 72 t 2 "max-concurr
1c50: 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 2d ent-jobs: " max-
1c60: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
1c70: 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a 20 ", num-running:
1c80: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a 09 " num-running)..
1c90: 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 6e 75 (set! *last-nu
1ca0: 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a m-running-tests*
1cb0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 0a num-running))).
1cc0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
1cd0: 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 ? 0 *globalexits
1ce0: 74 61 74 75 73 2a 29 29 0a 09 28 6c 69 73 74 20 tatus*))..(list
1cf0: 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e #f num-running n
1d00: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
1d10: 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 bgroup max-concu
1d20: 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 rrent-jobs job-g
1d30: 72 6f 75 70 2d 6c 69 6d 69 74 29 0a 09 28 6c 65 roup-limit)..(le
1d40: 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d t ((can-not-run-
1d50: 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 20 more (cond.....
1d60: 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 72 ;; if max-concur
1d70: 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 74 rent-jobs is set
1d80: 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 20 and the number
1d90: 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 74 running is great
1da0: 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e er ..... ;; than
1db0: 20 69 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 20 it than cannot
1dc0: 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 09 run more jobs...
1dd0: 09 09 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f 6e .. ((and max-con
1de0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 3e 3d current-jobs (>=
1df0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6d 61 78 num-running max
1e00: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1e10: 29 29 0a 09 09 09 09 20 20 28 69 66 20 28 72 75 ))..... (if (ru
1e20: 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 6d 63 6a ns:lownoise "mcj
1e30: 20 6d 73 67 22 20 36 30 29 0a 09 09 09 09 20 20 msg" 60).....
1e40: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1e50: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 0 "WARNING: Max
1e60: 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 running jobs ex
1e70: 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 20 ceeded, current
1e80: 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 number running:
1e90: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 " num-running ..
1ea0: 09 09 09 09 09 20 20 20 22 2c 20 6d 61 78 5f 63 ..... ", max_c
1eb0: 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 oncurrent_jobs:
1ec0: 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 " max-concurrent
1ed0: 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 23 74 -jobs))..... #t
1ee0: 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f 62 )..... ;; if job
1ef0: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 20 -group-limit is
1f00: 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 6f set and number o
1f10: 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 72 f jobs in the gr
1f20: 6f 75 70 20 69 73 20 67 72 65 61 74 65 72 0a 09 oup is greater..
1f30: 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 20 ... ;; than the
1f40: 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e 6f limit then canno
1f50: 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 t run more jobs
1f60: 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 09 of this kind....
1f70: 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 . ((and job-grou
1f80: 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 20 p-limit.....
1f90: 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 (>= num-runni
1fa0: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a ng-in-jobgroup j
1fb0: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 ob-group-limit))
1fc0: 0a 09 09 09 09 20 20 28 69 66 20 28 72 75 6e 73 ..... (if (runs
1fd0: 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 :lownoise (conc
1fe0: 22 6d 61 78 6a 6f 62 67 72 6f 75 70 20 22 20 6a "maxjobgroup " j
1ff0: 6f 62 67 72 6f 75 70 29 20 36 30 29 0a 09 09 09 obgroup) 60)....
2000: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
2010: 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 int 1 "WARNING:
2020: 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 22 number of jobs "
2030: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d num-running-in-
2040: 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 09 09 jobgroup .......
2050: 20 20 20 22 20 69 6e 20 6a 6f 62 67 72 6f 75 70 " in jobgroup
2060: 20 5c 22 22 20 6a 6f 62 67 72 6f 75 70 20 22 5c \"" jobgroup "\
2070: 22 20 65 78 63 65 65 64 73 20 6c 69 6d 69 74 20 " exceeds limit
2080: 6f 66 20 22 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c of " job-group-l
2090: 69 6d 69 74 29 29 0a 09 09 09 09 20 20 23 74 29 imit))..... #t)
20a0: 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 29 29 ..... (else #f))
20b0: 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f 74 )).. (list (not
20c0: 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 can-not-run-mor
20d0: 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e e) num-running n
20e0: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
20f0: 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 bgroup max-concu
2100: 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 rrent-jobs job-g
2110: 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 0a roup-limit))))).
2120: 0a 0a 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 73 ..;; test-names
2130: 3a 20 43 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 : Comma separate
2140: 64 20 70 61 74 74 65 72 6e 73 20 73 61 6d 65 20 d patterns same
2150: 61 73 20 74 65 73 74 2d 70 61 74 74 73 20 62 75 as test-patts bu
2160: 74 20 75 73 65 64 20 69 6e 20 73 65 6c 65 63 74 t used in select
2170: 69 6f 6e 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 ion .;;
2180: 20 20 20 20 20 6f 66 20 74 65 73 74 73 20 74 6f of tests to
2190: 20 72 75 6e 2e 20 54 68 65 20 69 74 65 6d 20 70 run. The item p
21a0: 6f 72 74 69 6f 6e 73 20 61 72 65 20 6e 6f 74 20 ortions are not
21b0: 72 65 73 70 65 63 74 65 64 2e 0a 3b 3b 20 20 20 respected..;;
21c0: 20 20 20 20 20 20 20 20 20 20 20 46 49 58 4d 45 FIXME
21d0: 3a 20 65 72 72 6f 72 20 6f 75 74 20 69 66 20 2f : error out if /
21e0: 70 61 74 74 20 73 70 65 63 69 66 69 65 64 0a 3b patt specified.;
21f0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 0a 28 64 ; .(d
2200: 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d efine (runs:run-
2210: 74 65 73 74 73 20 74 61 72 67 65 74 20 72 75 6e tests target run
2220: 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 name test-patts
2230: 75 73 65 72 20 66 6c 61 67 73 20 23 21 6b 65 79 user flags #!key
2240: 20 28 72 75 6e 2d 63 6f 75 6e 74 20 33 29 29 20 (run-count 3))
2250: 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 73 0a 20 20 ;; test-names.
2260: 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 (let* ((keys
2270: 20 20 20 20 20 20 20 20 20 20 20 28 6b 65 79 73 (keys
2280: 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c :config-get-fiel
2290: 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 ds *configdat*))
22a0: 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 .. (keyvals
22b0: 20 20 20 20 20 20 20 28 6b 65 79 73 3a 74 61 72 (keys:tar
22c0: 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 get->keyval keys
22d0: 20 74 61 72 67 65 74 29 29 0a 09 20 28 72 75 6e target)).. (run
22e0: 2d 69 64 20 20 20 20 20 20 20 20 20 20 20 20 20 -id
22f0: 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 (rmt:register-ru
2300: 6e 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d n keyvals runnam
2310: 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 e "new" "n/a" us
2320: 65 72 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e er)) ;; test-n
2330: 61 6d 65 29 29 29 0a 09 20 28 64 65 66 65 72 72 ame))).. (deferr
2340: 65 64 20 20 20 20 20 20 20 20 20 20 27 28 29 29 ed '())
2350: 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e 69 6e ;; delay runnin
2360: 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 74 68 g these since th
2370: 65 79 20 68 61 76 65 20 61 20 77 61 69 74 6f 6e ey have a waiton
2380: 20 63 6c 61 75 73 65 0a 09 20 28 72 75 6e 63 6f clause.. (runco
2390: 6e 66 69 67 66 20 20 20 20 20 20 20 20 20 28 63 nfigf (c
23a0: 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 onc *toppath* "
23b0: 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
23c0: 69 67 22 29 29 0a 09 20 28 74 65 73 74 2d 72 65 ig")).. (test-re
23d0: 63 6f 72 64 73 20 20 20 20 20 20 20 28 6d 61 6b cords (mak
23e0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
23f0: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 70 72 6f 63 ;; need to proc
2400: 65 73 73 20 72 75 6e 63 6f 6e 66 69 67 73 20 62 ess runconfigs b
2410: 65 66 6f 72 65 20 67 65 6e 65 72 61 74 69 6e 67 efore generating
2420: 20 74 68 65 73 65 20 6c 69 73 74 73 0a 09 20 28 these lists.. (
2430: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
2440: 72 79 20 23 66 29 20 20 3b 3b 20 28 74 65 73 74 ry #f) ;; (test
2450: 73 3a 67 65 74 2d 61 6c 6c 29 29 20 3b 3b 20 28 s:get-all)) ;; (
2460: 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d tests:get-valid-
2470: 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 61 73 68 tests (make-hash
2480: 2d 74 61 62 6c 65 29 20 74 65 73 74 2d 73 65 61 -table) test-sea
2490: 72 63 68 2d 70 61 74 68 29 29 20 3b 3b 20 61 6c rch-path)) ;; al
24a0: 6c 20 76 61 6c 69 64 20 74 65 73 74 73 20 74 6f l valid tests to
24b0: 20 63 68 65 63 6b 20 77 61 69 74 6f 6e 20 6e 61 check waiton na
24c0: 6d 65 73 0a 09 20 28 61 6c 6c 2d 74 65 73 74 2d mes.. (all-test-
24d0: 6e 61 6d 65 73 20 20 20 20 20 23 66 29 20 20 3b names #f) ;
24e0: 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 ; (hash-table-ke
24f0: 79 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 ys all-tests-reg
2500: 69 73 74 72 79 29 29 0a 09 20 28 74 65 73 74 2d istry)).. (test-
2510: 6e 61 6d 65 73 20 20 20 20 20 20 20 20 20 23 66 names #f
2520: 29 20 20 3b 3b 20 28 74 65 73 74 73 3a 66 69 6c ) ;; (tests:fil
2530: 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 61 ter-test-names a
2540: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 ll-test-names te
2550: 73 74 2d 70 61 74 74 73 29 29 0a 09 20 28 72 65 st-patts)).. (re
2560: 71 75 69 72 65 64 2d 74 65 73 74 73 20 20 20 20 quired-tests
2570: 20 23 66 29 20 20 3b 3b 28 6c 73 65 74 2d 69 6e #f) ;;(lset-in
2580: 74 65 72 73 65 63 74 69 6f 6e 20 65 71 75 61 6c tersection equal
2590: 3f 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 ? (string-split
25a0: 74 65 73 74 2d 70 61 74 74 73 20 22 2c 22 29 20 test-patts ",")
25b0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 3b 3b test-names))) ;;
25c0: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 20 3b 3b test-names)) ;;
25d0: 20 41 64 64 65 64 20 74 65 73 74 2d 6e 61 6d 65 Added test-name
25e0: 73 20 61 73 20 69 6e 69 74 69 61 6c 20 66 6f 72 s as initial for
25f0: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
2600: 62 75 74 20 74 68 61 74 20 66 61 69 6c 65 64 20 but that failed
2610: 74 6f 20 77 6f 72 6b 0a 09 20 28 74 61 73 6b 2d to work.. (task-
2620: 6b 65 79 20 20 20 20 20 20 20 20 20 20 20 28 63 key (c
2630: 6f 6e 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d onc (hash-table-
2640: 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 20 22 20 >alist flags) "
2650: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
2660: 29 20 22 20 22 20 28 63 75 72 72 65 6e 74 2d 70 ) " " (current-p
2670: 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 09 20 28 rocess-id))).. (
2680: 74 64 62 64 61 74 20 20 20 20 20 20 20 20 20 20 tdbdat
2690: 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 (tasks:open-d
26a0: 62 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 74 b))).. (if (t
26b0: 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 76 65 72 asks:need-server
26c0: 20 72 75 6e 2d 69 64 29 28 74 61 73 6b 73 3a 73 run-id)(tasks:s
26d0: 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f tart-and-wait-fo
26e0: 72 2d 73 65 72 76 65 72 20 74 64 62 64 61 74 20 r-server tdbdat
26f0: 72 75 6e 2d 69 64 20 31 30 29 29 0a 0a 20 20 20 run-id 10))..
2700: 20 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e (set-signal-han
2710: 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 dler! signal/int
2720: 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 73 69 .... (lambda (si
2730: 67 6e 75 6d 29 0a 09 09 09 20 20 20 28 73 69 67 gnum).... (sig
2740: 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d nal-mask! signum
2750: 29 0a 09 09 09 20 20 20 28 70 72 69 6e 74 20 22 ).... (print "
2760: 52 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c 20 Received signal
2770: 22 20 73 69 67 6e 75 6d 20 22 2c 20 63 6c 65 61 " signum ", clea
2780: 6e 69 6e 67 20 75 70 20 62 65 66 6f 72 65 20 65 ning up before e
2790: 78 69 74 2e 20 50 6c 65 61 73 65 20 77 61 69 74 xit. Please wait
27a0: 2e 2e 2e 22 29 0a 09 09 09 20 20 20 28 6c 65 74 ...").... (let
27b0: 20 28 28 74 64 62 64 61 74 20 28 74 61 73 6b 73 ((tdbdat (tasks
27c0: 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 09 09 09 20 :open-db)))....
27d0: 20 20 20 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 (rmt:tasks-s
27e0: 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 et-state-given-p
27f0: 61 72 61 6d 2d 6b 65 79 20 74 61 73 6b 2d 6b 65 aram-key task-ke
2800: 79 20 22 6b 69 6c 6c 65 64 22 29 29 0a 09 09 09 y "killed"))....
2810: 20 20 20 28 70 72 69 6e 74 20 22 4b 69 6c 6c 65 (print "Kille
2820: 64 20 62 79 20 73 69 67 6e 61 6c 20 22 20 73 69 d by signal " si
2830: 67 6e 75 6d 20 22 2e 20 45 78 69 74 69 6e 67 22 gnum ". Exiting"
2840: 29 0a 09 09 09 20 20 20 28 65 78 69 74 29 29 29 ).... (exit)))
2850: 0a 0a 20 20 20 20 3b 3b 20 72 65 67 69 73 74 65 .. ;; registe
2860: 72 20 74 68 69 73 20 72 75 6e 20 69 6e 20 6d 6f r this run in mo
2870: 6e 69 74 6f 72 2e 64 62 0a 20 20 20 20 28 72 6d nitor.db. (rm
2880: 74 3a 74 61 73 6b 73 2d 61 64 64 20 22 72 75 6e t:tasks-add "run
2890: 2d 74 65 73 74 73 22 20 75 73 65 72 20 74 61 72 -tests" user tar
28a0: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
28b0: 2d 70 61 74 74 73 20 74 61 73 6b 2d 6b 65 79 29 -patts task-key)
28c0: 20 3b 3b 20 70 61 72 61 6d 73 29 0a 20 20 20 20 ;; params).
28d0: 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 74 2d 73 (rmt:tasks-set-s
28e0: 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d tate-given-param
28f0: 2d 6b 65 79 20 74 61 73 6b 2d 6b 65 79 20 22 72 -key task-key "r
2900: 75 6e 6e 69 6e 67 22 29 0a 20 20 20 20 28 72 75 unning"). (ru
2910: 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 73 74 2d ns:set-megatest-
2920: 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 env-vars run-id
2930: 69 6e 6b 65 79 73 3a 20 6b 65 79 73 20 69 6e 72 inkeys: keys inr
2940: 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 unname: runname)
2950: 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 ;; these may be
2960: 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 6c needed by the l
2970: 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 aunching process
2980: 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
2990: 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 xists? runconfig
29a0: 66 29 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 f)..(setup-env-d
29b0: 65 66 61 75 6c 74 73 20 72 75 6e 63 6f 6e 66 69 efaults runconfi
29c0: 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 gf run-id *alrea
29d0: 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 dy-seen-runconfi
29e0: 67 2d 69 6e 66 6f 2a 20 6b 65 79 76 61 6c 73 20 g-info* keyvals
29f0: 74 61 72 67 65 74 29 0a 09 28 64 65 62 75 67 3a target)..(debug:
2a00: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
2a10: 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 : You do not hav
2a20: 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 e a run config f
2a30: 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 ile: " runconfig
2a40: 66 29 29 0a 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 f)).. ;; Now
2a50: 67 65 6e 65 72 61 74 65 20 61 6c 6c 20 74 68 65 generate all the
2a60: 20 74 65 73 74 73 20 6c 69 73 74 73 0a 20 20 20 tests lists.
2a70: 20 28 73 65 74 21 20 61 6c 6c 2d 74 65 73 74 73 (set! all-tests
2a80: 2d 72 65 67 69 73 74 72 79 20 28 74 65 73 74 73 -registry (tests
2a90: 3a 67 65 74 2d 61 6c 6c 29 29 0a 20 20 20 20 28 :get-all)). (
2aa0: 73 65 74 21 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 set! all-test-na
2ab0: 6d 65 73 20 20 20 20 20 28 68 61 73 68 2d 74 61 mes (hash-ta
2ac0: 62 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 65 73 ble-keys all-tes
2ad0: 74 73 2d 72 65 67 69 73 74 72 79 29 29 0a 20 20 ts-registry)).
2ae0: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
2af0: 65 73 20 20 20 20 20 20 20 20 20 28 74 65 73 74 es (test
2b00: 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 s:filter-test-na
2b10: 6d 65 73 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d mes all-test-nam
2b20: 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 29 0a es test-patts)).
2b30: 20 20 20 20 28 73 65 74 21 20 72 65 71 75 69 72 (set! requir
2b40: 65 64 2d 74 65 73 74 73 20 20 20 20 20 28 6c 73 ed-tests (ls
2b50: 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 et-intersection
2b60: 65 71 75 61 6c 3f 20 28 73 74 72 69 6e 67 2d 73 equal? (string-s
2b70: 70 6c 69 74 20 74 65 73 74 2d 70 61 74 74 73 20 plit test-patts
2b80: 22 2c 22 29 20 74 65 73 74 2d 6e 61 6d 65 73 29 ",") test-names)
2b90: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c 6f ). . ;; lo
2ba0: 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 20 ok up all tests
2bb0: 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f 6d matching the com
2bc0: 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 73 ma separated lis
2bd0: 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 20 t of globs in.
2be0: 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 20 ;; test-patts
2bf0: 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c 64 (using % as wild
2c00: 63 61 72 64 29 0a 0a 20 20 20 20 3b 3b 20 28 73 card).. ;; (s
2c10: 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 et! test-names (
2c20: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
2c30: 73 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c s (tests:get-val
2c40: 69 64 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 id-tests *toppat
2c50: 68 2a 20 74 65 73 74 2d 70 61 74 74 73 29 29 29 h* test-patts)))
2c60: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
2c70: 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 73 20 t-info 0 "tests
2c80: 73 65 61 72 63 68 20 70 61 74 68 3a 20 22 20 28 search path: " (
2c90: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d tests:get-tests-
2ca0: 73 65 61 72 63 68 2d 70 61 74 68 20 2a 63 6f 6e search-path *con
2cb0: 66 69 67 64 61 74 2a 29 29 0a 20 20 20 20 28 64 figdat*)). (d
2cc0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2cd0: 30 20 22 61 6c 6c 20 74 65 73 74 73 3a 20 20 22 0 "all tests: "
2ce0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2cf0: 65 72 73 65 20 28 73 6f 72 74 20 61 6c 6c 2d 74 erse (sort all-t
2d00: 65 73 74 2d 6e 61 6d 65 73 20 73 74 72 69 6e 67 est-names string
2d10: 3c 29 20 22 20 22 29 29 0a 20 20 20 20 28 64 65 <) " ")). (de
2d20: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
2d30: 20 22 74 65 73 74 20 6e 61 6d 65 73 3a 20 22 20 "test names: "
2d40: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
2d50: 72 73 65 20 28 73 6f 72 74 20 74 65 73 74 2d 6e rse (sort test-n
2d60: 61 6d 65 73 20 73 74 72 69 6e 67 3c 29 20 22 20 ames string<) "
2d70: 22 29 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 ")).. ;; on t
2d80: 68 65 20 66 69 72 73 74 20 70 61 73 73 20 6f 72 he first pass or
2d90: 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 call to run-tes
2da0: 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 6f 20 ts set FAILS to
2db0: 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 0a 20 NOT_STARTED if.
2dc0: 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
2dd0: 20 69 73 20 73 70 65 63 69 66 69 65 64 0a 20 20 is specified.
2de0: 20 20 28 69 66 20 28 65 71 3f 20 2a 70 61 73 73 (if (eq? *pass
2df0: 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 6e 0a num* 0)..(begin.
2e00: 09 20 20 3b 3b 20 49 73 20 74 68 69 73 20 73 74 . ;; Is this st
2e10: 69 6c 6c 20 6e 65 63 65 73 73 61 72 79 3f 20 49 ill necessary? I
2e20: 20 74 68 69 6e 6b 20 6e 6f 74 2e 20 55 6e 72 65 think not. Unre
2e30: 61 63 68 61 62 6c 65 20 74 65 73 74 73 20 61 72 achable tests ar
2e40: 65 20 6d 61 72 6b 65 64 20 61 73 20 73 75 63 68 e marked as such
2e50: 20 61 6e 64 20 0a 09 20 20 3b 3b 20 73 68 6f 75 and .. ;; shou
2e60: 6c 64 20 6e 6f 74 20 63 61 75 73 65 20 70 72 6f ld not cause pro
2e70: 62 6c 65 6d 73 20 68 65 72 65 2e 0a 09 20 20 3b blems here... ;
2e80: 3b 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 ;.. ;; have to
2e90: 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f delete test reco
2ea0: 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 rds where NOT_ST
2eb0: 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 ARTED since they
2ec0: 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 can cause -keep
2ed0: 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 going to .. ;;
2ee0: 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f get stuck due to
2ef0: 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 becoming inacce
2f00: 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 ssible from a fa
2f10: 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 iled test. I.e.
2f20: 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 if test B depend
2f30: 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 s .. ;; on test
2f40: 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 A but test B re
2f50: 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 ached the point
2f60: 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 on being registe
2f70: 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 red as NOT_START
2f80: 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b ED and test.. ;
2f90: 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 ; A failed for s
2fa0: 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 ome reason then
2fb0: 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 on re-run using
2fc0: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 -keepgoing the r
2fd0: 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d un can never com
2fe0: 70 6c 65 74 65 2e 0a 09 20 20 3b 3b 0a 09 20 20 plete... ;;..
2ff0: 3b 3b 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d ;; (rmt:general-
3000: 63 61 6c 6c 20 27 64 65 6c 65 74 65 2d 74 65 73 call 'delete-tes
3010: 74 73 2d 69 6e 2d 73 74 61 74 65 20 72 75 6e 2d ts-in-state run-
3020: 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 id "NOT_STARTED"
3030: 29 0a 09 20 20 0a 09 20 20 3b 3b 20 4e 6f 77 20 ).. .. ;; Now
3040: 63 6f 6e 76 65 72 74 20 46 41 49 4c 20 61 6e 64 convert FAIL and
3050: 20 61 6e 79 74 68 69 6e 67 20 69 6e 20 61 6c 6c anything in all
3060: 6f 77 2d 61 75 74 6f 2d 72 65 72 75 6e 20 74 6f ow-auto-rerun to
3070: 20 4e 4f 54 5f 53 54 41 52 54 45 44 0a 09 20 20 NOT_STARTED..
3080: 3b 3b 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 20 ;;.. (for-each
3090: 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a (lambda (state).
30a0: 09 09 20 20 20 20 20 20 28 72 6d 74 3a 73 65 74 .. (rmt:set
30b0: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
30c0: 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d tus run-id test-
30d0: 6e 61 6d 65 73 20 73 74 61 74 65 20 23 66 20 22 names state #f "
30e0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 73 74 61 NOT_STARTED" sta
30f0: 74 65 29 29 0a 09 09 20 20 20 20 28 73 74 72 69 te))... (stri
3100: 6e 67 2d 73 70 6c 69 74 20 28 6f 72 20 28 63 6f ng-split (or (co
3110: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
3120: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
3130: 20 22 61 6c 6c 6f 77 2d 61 75 74 6f 2d 72 65 72 "allow-auto-rer
3140: 75 6e 22 29 20 22 22 29 29 29 29 29 0a 0a 20 20 un") "")))))..
3150: 20 20 3b 3b 20 45 6e 73 75 72 65 20 61 6c 6c 20 ;; Ensure all
3160: 74 65 73 74 73 20 61 72 65 20 72 65 67 69 73 74 tests are regist
3170: 65 72 65 64 20 69 6e 20 74 68 65 20 74 65 73 74 ered in the test
3180: 5f 6d 65 74 61 20 74 61 62 6c 65 0a 20 20 20 20 _meta table.
3190: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c (runs:update-all
31a0: 2d 74 65 73 74 5f 6d 65 74 61 20 23 66 29 0a 0a -test_meta #f)..
31b0: 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e ;; now add n
31c0: 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 66 65 on-directly refe
31d0: 72 65 6e 63 65 64 20 64 65 70 65 6e 64 65 6e 63 renced dependenc
31e0: 69 65 73 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e ies (i.e. waiton
31f0: 29 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ). ;;========
3200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 ==============.
3240: 20 20 20 3b 3b 20 72 65 66 61 63 74 6f 72 69 6e ;; refactorin
3250: 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 69 6e 74 g this block int
3260: 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c o tests:get-full
3270: 2d 64 61 74 61 0a 20 20 20 20 3b 3b 0a 20 20 20 -data. ;;.
3280: 20 3b 3b 20 57 68 61 74 20 68 61 70 70 65 6e 64 ;; What happend
3290: 65 64 2c 20 74 68 69 73 20 63 6f 64 65 20 69 73 ed, this code is
32a0: 20 6e 6f 77 20 64 75 70 6c 69 63 61 74 65 64 20 now duplicated
32b0: 69 6e 20 74 65 73 74 73 21 3f 0a 20 20 20 20 3b in tests!?. ;
32c0: 3b 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ;. ;;========
32d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 ==============.
3310: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
3320: 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a l? test-names)).
3330: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 .(let loop ((hed
3340: 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 (car test-names
3350: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 ))... (tal (cd
3360: 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 r test-names)))
3370: 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 75 ;; 'retu
3380: 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 rn-procs tells t
3390: 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 72 he config reader
33a0: 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 to prep running
33b0: 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 75 system but retu
33c0: 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 63 68 rn a proc.. (ch
33d0: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a ange-directory *
33e0: 74 6f 70 70 61 74 68 2a 29 20 3b 3b 20 50 4c 45 toppath*) ;; PLE
33f0: 41 53 45 20 4f 50 54 49 4d 49 5a 45 20 4d 45 21 ASE OPTIMIZE ME!
3400: 21 21 20 49 20 74 68 69 6e 6b 20 74 68 69 73 20 !! I think this
3410: 73 68 6f 75 6c 64 20 62 65 20 61 20 6e 6f 2d 6f should be a no-o
3420: 70 20 62 75 74 20 74 68 65 72 65 20 61 72 65 20 p but there are
3430: 73 65 76 65 72 61 6c 20 70 6c 61 63 65 73 20 77 several places w
3440: 68 65 72 65 20 63 68 61 6e 67 65 2d 64 69 72 65 here change-dire
3450: 63 74 6f 72 69 65 73 20 63 6f 75 6c 64 20 62 65 ctories could be
3460: 20 68 61 70 70 65 6e 69 6e 67 2e 0a 09 20 20 28 happening... (
3470: 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f setenv "MT_TEST_
3480: 4e 41 4d 45 22 20 68 65 64 29 20 3b 3b 20 0a 09 NAME" hed) ;; ..
3490: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 (let* ((config
34a0: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 (tests:get-tes
34b0: 74 63 6f 6e 66 69 67 20 68 65 64 20 61 6c 6c 2d tconfig hed all-
34c0: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 tests-registry '
34d0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 return-procs))..
34e0: 09 20 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 . (waitons (let
34f0: 28 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 ((instr (if conf
3500: 69 67 20 0a 09 09 09 09 09 20 20 20 28 63 6f 6e ig ...... (con
3510: 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 fig-lookup confi
3520: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
3530: 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 "waiton")......
3540: 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 (begin ;; No
3550: 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 config means thi
3560: 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 s is a non-exist
3570: 61 6e 74 20 74 65 73 74 0a 09 09 09 09 09 20 20 ant test......
3580: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3590: 30 20 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 0 "ERROR: non-ex
35a0: 69 73 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 istent required
35b0: 74 65 73 74 20 5c 22 22 20 68 65 64 20 22 5c 22 test \"" hed "\"
35c0: 22 29 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 ")...... (ex
35d0: 69 74 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 it 1)))))....
35e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
35f0: 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 fo 8 "waitons st
3600: 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 ring is " instr)
3610: 0a 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 6e .... (let ((n
3620: 65 77 77 61 69 74 6f 6e 73 0a 09 09 09 09 20 20 ewwaitons.....
3630: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
3640: 63 6f 6e 64 0a 09 09 09 09 09 09 20 20 28 28 70 cond....... ((p
3650: 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 rocedure? instr)
3660: 0a 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 ....... (let (
3670: 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 (res (instr)))..
3680: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
3690: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 :print-info 8 "w
36a0: 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 aiton procedure
36b0: 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e results in strin
36c0: 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 g " res " for te
36d0: 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 09 st " hed).......
36e0: 20 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 res))......
36f0: 09 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 . ((string? ins
3700: 74 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 tr) instr)..
3710: 09 09 09 09 09 20 20 28 65 6c 73 65 20 0a 09 09 ..... (else ...
3720: 09 09 09 09 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 .... ;; NOTE:
3730: 54 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 This is actually
3740: 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f the case of *no
3750: 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 * waitons! ;; (d
3760: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
3770: 52 4f 52 3a 20 73 6f 6d 65 74 68 69 6e 67 20 77 ROR: something w
3780: 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f ent wrong in pro
3790: 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 cessing waitons
37a0: 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 0a for test " hed).
37b0: 09 09 09 09 09 09 20 20 20 22 22 29 29 29 29 29 ...... "")))))
37c0: 0a 09 09 09 20 20 20 20 20 20 28 66 69 6c 74 65 .... (filte
37d0: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
37e0: 09 09 09 28 69 66 20 28 68 61 73 68 2d 74 61 62 ...(if (hash-tab
37f0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 le-ref/default a
3800: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
3810: 79 20 78 20 23 66 29 0a 09 09 09 09 09 20 20 20 y x #f)......
3820: 20 23 74 0a 09 09 09 09 09 20 20 20 20 28 62 65 #t...... (be
3830: 67 69 6e 0a 09 09 09 09 09 20 20 20 20 20 20 28 gin...... (
3840: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
3850: 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 RROR: test " hed
3860: 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 " has unrecogni
3870: 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e sed waiton testn
3880: 61 6d 65 20 22 20 78 29 0a 09 09 09 09 09 20 20 ame " x)......
3890: 20 20 20 20 23 66 29 29 29 0a 09 09 09 09 20 20 #f))).....
38a0: 20 20 20 20 6e 65 77 77 61 69 74 6f 6e 73 29 29 newwaitons))
38b0: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
38c0: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 print-info 8 "wa
38d0: 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 itons: " waitons
38e0: 29 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 ).. ;; check
38f0: 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f for hed in waito
3900: 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 ns => this would
3910: 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 be circular, re
3920: 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 move it and issu
3930: 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 e an.. ;; err
3940: 6f 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d or.. (if (mem
3950: 62 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 ber hed waitons)
3960: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
3970: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
3980: 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 ROR: test " hed
3990: 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 " has listed its
39a0: 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c elf as a waiton,
39b0: 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 please correct
39c0: 74 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 this!")... (set
39d0: 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 ! waitons (filte
39e0: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f r (lambda (x)(no
39f0: 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 t (equal? x hed)
3a00: 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 )) waitons))))..
3a10: 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 74 .. ;; (it
3a20: 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 74 ems (items:get
3a30: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
3a40: 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 ig config)))..
3a50: 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 (if (not (hash
3a60: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3a70: 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 lt test-records
3a80: 68 65 64 20 23 66 29 29 0a 09 09 28 68 61 73 68 hed #f))...(hash
3a90: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
3aa0: 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 68 65 -records..... he
3ab0: 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 d (vector hed
3ac0: 20 20 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 20 ;; 0......
3ad0: 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 config ;; 1...
3ae0: 09 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 20 ... waitons
3af0: 3b 3b 20 32 0a 09 09 09 09 09 20 20 20 20 20 28 ;; 2...... (
3b00: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f config-lookup co
3b10: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
3b20: 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 20 ts" "priority")
3b30: 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 ;; priority
3b40: 33 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 3...... (let
3b50: 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 ((items (h
3b60: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3b70: 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
3b80: 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 ems" #f)) ;; ite
3b90: 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 28 69 ms 4....... (i
3ba0: 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d temstable (hash-
3bb0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
3bc0: 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 t config "itemst
3bd0: 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 09 able" #f))) ....
3be0: 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 .. ;; if e
3bf0: 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 ither items or i
3c00: 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 tems table is a
3c10: 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 proc return it s
3c20: 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 o test running..
3c30: 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 70 72 .... ;; pr
3c40: 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 ocess can know t
3c50: 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 o call items:get
3c60: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
3c70: 69 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ig...... ;
3c80: 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 61 ; if either is a
3c90: 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 list and none i
3ca0: 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 s a proc go ahea
3cb0: 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 d and call get-i
3cc0: 74 65 6d 73 0a 09 09 09 09 09 20 20 20 20 20 20 tems......
3cd0: 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 ;; otherwise re
3ce0: 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 turn #f - this i
3cf0: 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 s not an iterate
3d00: 64 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 d test......
3d10: 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 28 (cond.......(
3d20: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
3d30: 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 20 s) .......
3d40: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3d50: 6f 20 34 20 22 69 74 65 6d 73 20 69 73 20 61 20 o 4 "items is a
3d60: 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
3d70: 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
3d80: 09 09 09 20 69 74 65 6d 73 29 20 20 20 20 20 20 ... items)
3d90: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
3da0: 74 65 72 0a 09 09 09 09 09 09 28 28 70 72 6f 63 ter.......((proc
3db0: 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c edure? itemstabl
3dc0: 65 29 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 e)....... (debug
3dd0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 :print-info 4 "i
3de0: 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 temstable is a p
3df0: 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 rocedure, will c
3e00: 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 alc later").....
3e10: 09 09 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 .. itemstable)
3e20: 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 ;; calc lat
3e30: 65 72 0a 09 09 09 09 09 09 28 28 66 69 6c 74 65 er.......((filte
3e40: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
3e50: 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 76 ..... (let ((v
3e60: 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 09 al (car x)))....
3e70: 09 09 09 09 20 20 20 20 20 28 69 66 20 28 70 72 .... (if (pr
3e80: 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 ocedure? val) va
3e90: 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 l #f)))........
3ea0: 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 (append (if (lis
3eb0: 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 t? items) items
3ec0: 27 28 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 '())......... (i
3ed0: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 f (list? itemsta
3ee0: 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 ble) itemstable
3ef0: 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 27 68 '())))....... 'h
3f00: 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 ave-procedure)..
3f10: 09 09 09 09 09 28 28 6f 72 20 28 6c 69 73 74 3f .....((or (list?
3f20: 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 items)(list? it
3f30: 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 emstable)) ;; ca
3f40: 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 lc now....... (d
3f50: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3f60: 34 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 4 "items and ite
3f70: 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 mstable are list
3f80: 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 s, calc now\n"..
3f90: 09 09 09 09 09 09 09 20 20 20 22 20 20 20 20 69 ....... " i
3fa0: 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 tems: " items "
3fb0: 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 itemstable: " it
3fc0: 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 emstable).......
3fd0: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
3fe0: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f s-from-config co
3ff0: 6e 66 69 67 29 29 0a 09 09 09 09 09 09 28 65 6c nfig)).......(el
4000: 73 65 20 23 66 29 29 29 20 20 20 20 20 20 20 20 se #f)))
4010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4020: 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 ;; not iterat
4030: 65 64 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 ed...... #f
4040: 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 ;; itemsdat
4050: 20 35 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 5...... #f
4060: 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 ;; spare -
4070: 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 used for item-pa
4080: 74 68 0a 09 09 09 09 09 20 20 20 20 20 29 29 29 th...... )))
4090: 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 .. (for-each
40a0: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
40b0: 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 waiton)..
40c0: 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 (if (and waiton
40d0: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 (not (member wai
40e0: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
40f0: 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 )... (begin...
4100: 20 20 20 20 20 28 73 65 74 21 20 72 65 71 75 69 (set! requi
4110: 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 red-tests (cons
4120: 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d waiton required-
4130: 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 28 tests))... (
4140: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
4150: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 (cons waiton tes
4160: 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 t-names))))) ;;
4170: 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e was an append, n
4180: 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 20 20 20 ow a cons..
4190: 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c waitons).. (l
41a0: 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 et ((remtests (d
41b0: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
41c0: 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 (append waitons
41d0: 20 74 61 6c 29 29 29 29 0a 09 20 20 20 20 20 20 tal))))..
41e0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
41f0: 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 28 remtests))... (
4200: 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 loop (car remtes
4210: 74 73 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 ts)(cdr remtests
4220: 29 29 29 29 29 29 29 0a 0a 20 20 20 20 28 69 66 ))))))).. (if
4230: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 (not (null? req
4240: 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 28 uired-tests))..(
4250: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4260: 20 31 20 22 41 64 64 69 6e 67 20 22 20 72 65 71 1 "Adding " req
4270: 75 69 72 65 64 2d 74 65 73 74 73 20 22 20 74 6f uired-tests " to
4280: 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 the run queue")
4290: 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 74 ). ;; NOTE: t
42a0: 68 65 73 65 20 61 72 65 20 61 6c 6c 20 70 61 72 hese are all par
42b0: 65 6e 74 20 74 65 73 74 73 2c 20 69 74 65 6d 73 ent tests, items
42c0: 20 61 72 65 20 6e 6f 74 20 65 78 70 61 6e 64 65 are not expande
42d0: 64 20 79 65 74 2e 0a 20 20 20 20 28 64 65 62 75 d yet.. (debu
42e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
42f0: 74 65 73 74 2d 72 65 63 6f 72 64 73 3d 22 20 28 test-records=" (
4300: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
4310: 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 t test-records))
4320: 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 67 6c . (let ((regl
4330: 65 6e 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b en (configf:look
4340: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
4350: 73 65 74 75 70 22 20 22 72 75 6e 71 75 65 75 65 setup" "runqueue
4360: 22 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 "))). (if (
4370: 3e 20 28 6c 65 6e 67 74 68 20 28 68 61 73 68 2d > (length (hash-
4380: 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
4390: 72 65 63 6f 72 64 73 29 29 20 30 29 0a 09 20 20 records)) 0)..
43a0: 28 6c 65 74 2a 20 28 28 6b 65 65 70 2d 67 6f 69 (let* ((keep-goi
43b0: 6e 67 20 20 20 20 20 20 20 20 23 74 29 0a 09 09 ng #t)...
43c0: 20 28 72 75 6e 2d 71 75 65 75 65 2d 72 65 74 72 (run-queue-retr
43d0: 69 65 73 20 35 29 0a 09 09 20 28 74 68 31 20 20 ies 5)... (th1
43e0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 (make-thre
43f0: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
4400: 09 09 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ... (handle-e
4410: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 xceptions......
4420: 20 20 20 20 65 78 6e 0a 09 09 09 09 09 20 20 20 exn......
4430: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 (begin......
4440: 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c (print-call
4450: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
4460: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 09 error-port))....
4470: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
4480: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
4490: 66 61 69 6c 75 72 65 20 69 6e 20 72 75 6e 73 3a failure in runs:
44a0: 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 run-tests-queue
44b0: 74 68 72 65 61 64 2c 20 65 72 72 6f 72 3a 20 22 thread, error: "
44c0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
44d0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
44e0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
44f0: 6e 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 n))......
4500: 28 69 66 20 28 3e 20 72 75 6e 2d 71 75 65 75 65 (if (> run-queue
4510: 2d 72 65 74 72 69 65 73 20 30 29 0a 09 09 09 09 -retries 0).....
4520: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 .. (begin.....
4530: 09 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
4540: 2d 71 75 65 75 65 2d 72 65 74 72 69 65 73 20 28 -queue-retries (
4550: 2d 20 72 75 6e 2d 71 75 65 75 65 2d 72 65 74 72 - run-queue-retr
4560: 69 65 73 20 31 29 29 0a 09 09 09 09 09 09 20 20 ies 1)).......
4570: 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 (runs:run-tes
4580: 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 ts-queue run-id
4590: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 runname test-rec
45a0: 6f 72 64 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 ords keyvals fla
45b0: 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 gs test-patts re
45c0: 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 61 6e quired-tests (an
45d0: 79 2d 3e 6e 75 6d 62 65 72 20 72 65 67 6c 65 6e y->number reglen
45e0: 29 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 ) all-tests-regi
45f0: 73 74 72 79 29 29 29 29 0a 09 09 09 09 09 20 20 stry))))......
4600: 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 (runs:run-tes
4610: 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 ts-queue run-id
4620: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 runname test-rec
4630: 6f 72 64 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 ords keyvals fla
4640: 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 gs test-patts re
4650: 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 61 6e quired-tests (an
4660: 79 2d 3e 6e 75 6d 62 65 72 20 72 65 67 6c 65 6e y->number reglen
4670: 29 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 ) all-tests-regi
4680: 73 74 72 79 29 29 29 0a 09 09 09 09 09 20 20 22 stry)))...... "
4690: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
46a0: 75 65 75 65 22 29 29 0a 09 09 20 28 74 68 32 20 ueue"))... (th2
46b0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 (make-thr
46c0: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 09 09 ead (lambda ()..
46d0: 09 09 20 20 20 20 0a 09 09 09 09 09 20 20 20 20 .. ......
46e0: 3b 3b 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 ;; (rmt:find-and
46f0: 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 -mark-incomplete
4700: 2d 61 6c 6c 2d 72 75 6e 73 29 29 29 29 29 20 43 -all-runs))))) C
4710: 41 4e 27 54 20 49 4e 54 45 52 52 55 50 54 20 49 AN'T INTERRUPT I
4720: 54 20 2e 2e 2e 0a 09 09 09 09 09 20 20 20 20 28 T ......... (
4730: 6c 65 74 20 28 28 72 75 6e 2d 69 64 73 20 28 72 let ((run-ids (r
4740: 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 mt:get-all-run-i
4750: 64 73 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 ds)))......
4760: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
4770: 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 09 09 09 da (run-id).....
4780: 09 09 09 20 20 28 69 66 20 6b 65 65 70 2d 67 6f ... (if keep-go
4790: 69 6e 67 0a 09 09 09 09 09 09 09 20 20 20 20 20 ing........
47a0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
47b0: 6f 6e 73 0a 09 09 09 09 09 09 09 20 20 20 20 20 ons........
47c0: 20 20 65 78 6e 0a 09 09 09 09 09 09 09 20 20 20 exn........
47d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
47e0: 20 30 20 22 65 72 72 6f 72 20 69 6e 20 63 61 6c 0 "error in cal
47f0: 6c 69 6e 67 20 66 69 6e 64 2d 61 6e 64 2d 6d 61 ling find-and-ma
4800: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 66 6f rk-incomplete fo
4810: 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 r run-id " run-i
4820: 64 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 d)........
4830: 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d (rmt:find-and-m
4840: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 ark-incomplete r
4850: 75 6e 2d 69 64 20 23 66 29 29 29 29 20 3b 3b 20 un-id #f)))) ;;
4860: 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 29 0a ovr-deadtime))).
4870: 09 09 09 09 09 09 09 72 75 6e 2d 69 64 73 29 29 .......run-ids))
4880: 29 0a 09 09 09 09 09 20 20 22 72 75 6e 73 3a 20 )...... "runs:
4890: 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 73 mark-incompletes
48a0: 22 29 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 "))).. (threa
48b0: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 d-start! th1)..
48c0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
48d0: 21 20 74 68 32 29 0a 09 20 20 20 20 28 74 68 72 ! th2).. (thr
48e0: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 09 ead-join! th1)..
48f0: 20 20 20 20 28 73 65 74 21 20 6b 65 65 70 2d 67 (set! keep-g
4900: 6f 69 6e 67 20 23 66 29 0a 09 20 20 20 20 28 74 oing #f).. (t
4910: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 hread-join! th2)
4920: 0a 09 20 20 20 20 3b 3b 20 69 66 20 72 75 6e 2d .. ;; if run-
4930: 63 6f 75 6e 74 20 3e 20 30 20 63 61 6c 6c 2c 20 count > 0 call,
4940: 73 65 74 20 2d 70 72 65 63 6c 65 61 6e 20 61 6e set -preclean an
4950: 64 20 2d 72 65 72 75 6e 20 53 54 55 43 4b 2f 44 d -rerun STUCK/D
4960: 45 41 44 0a 09 20 20 20 20 28 69 66 20 28 3e 20 EAD.. (if (>
4970: 72 75 6e 2d 63 6f 75 6e 74 20 30 29 0a 09 09 28 run-count 0)...(
4980: 62 65 67 69 6e 0a 09 09 20 20 28 69 66 20 28 6e begin... (if (n
4990: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
49a0: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
49b0: 20 22 2d 70 72 65 63 6c 65 61 6e 22 20 23 66 29 "-preclean" #f)
49c0: 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 2d )... (hash-
49d0: 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 table-set! flags
49e0: 20 22 2d 70 72 65 63 6c 65 61 6e 22 20 23 74 29 "-preclean" #t)
49f0: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 )... (if (not (
4a00: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4a10: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 efault flags "-r
4a20: 65 72 75 6e 22 20 23 66 29 29 0a 09 09 20 20 20 erun" #f))...
4a30: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
4a40: 65 74 21 20 66 6c 61 67 73 20 22 2d 72 65 72 75 et! flags "-reru
4a50: 6e 22 20 22 53 54 55 43 4b 2f 44 45 41 44 2c 6e n" "STUCK/DEAD,n
4a60: 2f 61 2c 5a 45 52 4f 5f 49 54 45 4d 53 22 29 29 /a,ZERO_ITEMS"))
4a70: 0a 09 09 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 ... (runs:run-t
4a80: 65 73 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e ests target runn
4a90: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 ame test-patts u
4aa0: 73 65 72 20 66 6c 61 67 73 20 72 75 6e 2d 63 6f ser flags run-co
4ab0: 75 6e 74 3a 20 28 2d 20 72 75 6e 2d 63 6f 75 6e unt: (- run-coun
4ac0: 74 20 31 29 29 29 29 29 0a 09 20 20 28 64 65 62 t 1))))).. (deb
4ad0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
4ae0: 22 4e 6f 20 74 65 73 74 73 20 74 6f 20 72 75 6e "No tests to run
4af0: 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a "))). (debug:
4b00: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 41 6c print-info 4 "Al
4b10: 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 29 l done by here")
4b20: 0a 20 20 20 20 28 72 6d 74 3a 74 61 73 6b 73 2d . (rmt:tasks-
4b30: 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d set-state-given-
4b40: 70 61 72 61 6d 2d 6b 65 79 20 74 61 73 6b 2d 6b param-key task-k
4b50: 65 79 20 22 64 6f 6e 65 22 29 0a 20 20 20 20 3b ey "done"). ;
4b60: 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c ; (sqlite3:final
4b70: 69 7a 65 21 20 74 61 73 6b 73 2d 64 62 29 0a 20 ize! tasks-db).
4b80: 20 20 20 29 29 0a 0a 0a 3b 3b 20 6c 6f 6f 70 20 ))...;; loop
4b90: 6c 6f 67 69 63 2e 20 54 68 65 73 65 20 61 72 65 logic. These are
4ba0: 20 75 73 65 64 20 69 6e 20 72 75 6e 73 3a 72 75 used in runs:ru
4bb0: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 74 6f n-tests-queue to
4bc0: 20 6d 61 6b 65 20 69 74 20 61 20 62 69 74 20 6d make it a bit m
4bd0: 6f 72 65 20 72 65 61 64 61 62 6c 65 2e 0a 3b 3b ore readable..;;
4be0: 0a 3b 3b 20 49 66 20 72 65 67 20 6e 6f 74 20 66 .;; If reg not f
4bf0: 75 6c 6c 20 61 6e 64 20 68 61 76 65 20 69 74 65 ull and have ite
4c00: 6d 73 20 69 6e 20 74 61 6c 20 74 68 65 6e 20 6c ms in tal then l
4c10: 6f 6f 70 20 77 69 74 68 20 28 63 61 72 20 74 61 oop with (car ta
4c20: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 20 l)(cdr tal) reg
4c30: 72 65 72 75 6e 73 0a 3b 3b 20 49 66 20 72 65 67 reruns.;; If reg
4c40: 20 69 73 20 66 75 6c 6c 20 28 69 2e 65 2e 20 6c is full (i.e. l
4c50: 65 6e 67 74 68 20 3e 3d 20 6e 0a 3b 3b 20 20 20 ength >= n.;;
4c60: 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 72 20 72 loop with (car r
4c70: 65 67 29 20 74 61 6c 20 28 63 64 72 20 72 65 67 eg) tal (cdr reg
4c80: 29 20 72 65 72 75 6e 73 0a 3b 3b 20 49 66 20 74 ) reruns.;; If t
4c90: 61 6c 20 69 73 20 65 6d 70 74 79 0a 3b 3b 20 20 al is empty.;;
4ca0: 20 62 75 74 20 68 61 76 65 20 69 74 65 6d 73 20 but have items
4cb0: 69 6e 20 72 65 67 3b 20 6c 6f 6f 70 20 77 69 74 in reg; loop wit
4cc0: 68 20 28 63 61 72 20 72 65 67 29 28 63 64 72 20 h (car reg)(cdr
4cd0: 72 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 0a reg) '() reruns.
4ce0: 3b 3b 20 20 20 49 66 20 72 65 67 20 69 73 20 65 ;; If reg is e
4cf0: 6d 70 74 79 20 3d 3e 20 61 6c 6c 20 64 6f 6e 65 mpty => all done
4d00: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
4d10: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 queue-next-hed t
4d20: 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c 6c al reg n regfull
4d30: 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c 6c 0a ). (if regfull.
4d40: 20 20 20 20 20 20 28 63 61 72 20 72 65 67 29 0a (car reg).
4d50: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
4d60: 20 74 61 6c 29 20 3b 3b 20 74 61 6c 20 69 73 20 tal) ;; tal is
4d70: 75 73 65 64 20 75 70 2c 20 70 6f 70 20 66 72 6f used up, pop fro
4d80: 6d 20 72 65 67 0a 09 20 20 28 63 61 72 20 72 65 m reg.. (car re
4d90: 67 29 0a 09 20 20 28 63 61 72 20 74 61 6c 29 29 g).. (car tal))
4da0: 29 29 0a 0a 3b 3b 20 20 20 28 63 6f 6e 64 0a 3b ))..;; (cond.;
4db0: 3b 20 20 20 20 28 28 61 6e 64 20 72 65 67 66 75 ; ((and regfu
4dc0: 6c 6c 20 28 6e 75 6c 6c 3f 20 72 65 67 29 28 6e ll (null? reg)(n
4dd0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 ot (null? tal)))
4de0: 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 29 (car tal))
4df0: 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 72 65 67 .;; ((and reg
4e00: 66 75 6c 6c 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f full (not (null?
4e10: 20 72 65 67 29 29 29 20 20 20 20 20 20 20 20 20 reg)))
4e20: 20 20 20 20 20 20 20 20 28 63 61 72 20 72 65 67 (car reg
4e30: 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 28 )).;; ((and (
4e40: 6e 6f 74 20 72 65 67 66 75 6c 6c 29 28 6e 75 6c not regfull)(nul
4e50: 6c 3f 20 74 61 6c 29 28 6e 6f 74 20 28 6e 75 6c l? tal)(not (nul
4e60: 6c 3f 20 72 65 67 29 29 29 20 28 63 61 72 20 72 l? reg))) (car r
4e70: 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 eg)).;; ((and
4e80: 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c 29 28 6e (not regfull)(n
4e90: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 ot (null? tal)))
4ea0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 (car
4eb0: 20 74 61 6c 29 29 0a 3b 3b 20 20 20 20 28 65 6c tal)).;; (el
4ec0: 73 65 0a 3b 3b 20 20 20 20 20 28 64 65 62 75 67 se.;; (debug
4ed0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
4ee0: 20 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 runs:queue-next
4ef0: 2d 68 65 64 2c 20 74 61 6c 3d 22 20 74 61 6c 20 -hed, tal=" tal
4f00: 22 2c 20 72 65 67 3d 22 20 72 65 67 20 22 2c 20 ", reg=" reg ",
4f10: 6e 3d 22 20 6e 20 22 2c 20 72 65 67 66 75 6c 6c n=" n ", regfull
4f20: 3d 22 20 72 65 67 66 75 6c 6c 29 0a 3b 3b 20 20 =" regfull).;;
4f30: 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e #f)))..(defin
4f40: 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 e (runs:queue-ne
4f50: 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 6e xt-tal tal reg n
4f60: 20 72 65 67 66 75 6c 6c 29 0a 20 20 28 69 66 20 regfull). (if
4f70: 72 65 67 66 75 6c 6c 0a 20 20 20 20 20 20 74 61 regfull. ta
4f80: 6c 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c l. (if (nul
4f90: 6c 3f 20 74 61 6c 29 20 3b 3b 20 6d 75 73 74 20 l? tal) ;; must
4fa0: 74 72 61 6e 73 66 65 72 20 66 72 6f 6d 20 72 65 transfer from re
4fb0: 67 0a 09 20 20 28 63 64 72 20 72 65 67 29 0a 09 g.. (cdr reg)..
4fc0: 20 20 28 63 64 72 20 74 61 6c 29 29 29 29 0a 0a (cdr tal))))..
4fd0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 (define (runs:qu
4fe0: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
4ff0: 20 72 65 67 20 6e 20 72 65 67 66 75 6c 6c 29 0a reg n regfull).
5000: 20 20 28 69 66 20 72 65 67 66 75 6c 6c 0a 20 20 (if regfull.
5010: 20 20 20 20 28 63 64 72 20 72 65 67 29 0a 20 20 (cdr reg).
5020: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
5030: 61 6c 29 20 3b 3b 20 69 66 20 74 61 6c 20 69 73 al) ;; if tal is
5040: 20 6e 75 6c 6c 20 61 6e 64 20 72 65 67 20 6e 6f null and reg no
5050: 74 20 66 75 6c 6c 20 74 68 65 6e 20 27 28 29 20 t full then '()
5060: 61 73 20 72 65 67 20 63 6f 6e 74 65 6e 74 73 20 as reg contents
5070: 6d 6f 76 65 64 20 74 6f 20 74 61 6c 0a 09 20 20 moved to tal..
5080: 27 28 29 0a 09 20 20 72 65 67 29 29 29 0a 0a 28 '().. reg)))..(
5090: 64 65 66 69 6e 65 20 72 75 6e 73 3a 6e 6f 74 68 define runs:noth
50a0: 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 65 75 ing-left-in-queu
50b0: 65 2d 63 6f 75 6e 74 20 30 29 0a 0a 28 64 65 66 e-count 0)..(def
50c0: 69 6e 65 20 28 72 75 6e 73 3a 65 78 70 61 6e 64 ine (runs:expand
50d0: 2d 69 74 65 6d 73 20 68 65 64 20 74 61 6c 20 72 -items hed tal r
50e0: 65 67 20 72 65 72 75 6e 73 20 72 65 67 66 75 6c eg reruns regful
50f0: 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 67 72 6f 75 l newtal jobgrou
5100: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
5110: 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 -jobs run-id wai
5120: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 tons item-path t
5130: 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 72 65 63 estmode test-rec
5140: 6f 72 64 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ord can-run-more
5150: 20 69 74 65 6d 73 20 72 75 6e 6e 61 6d 65 20 74 items runname t
5160: 63 6f 6e 66 69 67 20 72 65 67 6c 65 6e 20 74 65 config reglen te
5170: 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 st-registry test
5180: 2d 72 65 63 6f 72 64 73 20 69 74 65 6d 6d 61 70 -records itemmap
5190: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 6f 70 ). (let* ((loop
51a0: 2d 6c 69 73 74 20 20 20 20 20 20 20 28 6c 69 73 -list (lis
51b0: 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t hed tal reg re
51c0: 72 75 6e 73 29 29 0a 09 20 28 70 72 65 72 65 71 runs)).. (prereq
51d0: 73 2d 6e 6f 74 2d 6d 65 74 20 28 72 6d 74 3a 67 s-not-met (rmt:g
51e0: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
51f0: 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e et run-id waiton
5200: 73 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 s item-path test
5210: 6d 6f 64 65 20 69 74 65 6d 6d 61 70 3a 20 69 74 mode itemmap: it
5220: 65 6d 6d 61 70 29 29 0a 09 20 3b 3b 20 28 70 72 emmap)).. ;; (pr
5230: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 6d ereqs-not-met (m
5240: 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 72 65 72 65 t:lazy-get-prere
5250: 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 qs-not-met run-i
5260: 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 d waitons item-p
5270: 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f ath mode: testmo
5280: 64 65 20 69 74 65 6d 6d 61 70 3a 20 69 74 65 6d de itemmap: item
5290: 6d 61 70 29 29 0a 09 20 28 66 61 69 6c 73 20 20 map)).. (fails
52a0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 (runs:c
52b0: 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 alc-fails prereq
52c0: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 70 s-not-met)).. (p
52d0: 72 65 72 65 71 2d 66 61 69 6c 73 20 20 20 20 28 rereq-fails (
52e0: 72 75 6e 73 3a 63 61 6c 63 2d 70 72 65 72 65 71 runs:calc-prereq
52f0: 2d 66 61 69 6c 20 70 72 65 72 65 71 73 2d 6e 6f -fail prereqs-no
5300: 74 2d 6d 65 74 29 29 0a 09 20 28 6e 6f 6e 2d 63 t-met)).. (non-c
5310: 6f 6d 70 6c 65 74 65 64 20 20 20 28 72 75 6e 73 ompleted (runs
5320: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
5330: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
5340: 6d 65 74 29 29 0a 09 20 28 72 75 6e 6e 61 62 6c met)).. (runnabl
5350: 65 73 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 es (runs:c
5360: 61 6c 63 2d 72 75 6e 6e 61 62 6c 65 20 70 72 65 alc-runnable pre
5370: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a reqs-not-met))).
5380: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5390: 2d 69 6e 66 6f 20 34 20 22 53 54 41 52 54 20 4f -info 4 "START O
53a0: 46 20 49 4e 4e 45 52 20 43 4f 4e 44 20 23 32 20 F INNER COND #2
53b0: 22 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 63 61 "... "\n ca
53c0: 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 20 20 22 n-run-more: "
53d0: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 can-run-more...
53e0: 20 20 20 20 20 20 22 5c 6e 20 74 65 73 74 6e 61 "\n testna
53f0: 6d 65 3a 20 20 20 20 20 20 20 20 22 20 68 65 64 me: " hed
5400: 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 70 72 65 ... "\n pre
5410: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 reqs-not-met: "
5420: 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 (runs:pretty-str
5430: 69 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ing prereqs-not-
5440: 6d 65 74 29 0a 09 09 20 20 20 20 20 20 22 5c 6e met)... "\n
5450: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 3a 20 non-completed:
5460: 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 " (runs:pretty
5470: 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f 6d 70 -string non-comp
5480: 6c 65 74 65 64 29 20 0a 09 09 20 20 20 20 20 20 leted) ...
5490: 22 5c 6e 20 70 72 65 72 65 71 2d 66 61 69 6c 73 "\n prereq-fails
54a0: 3a 20 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 : " (runs:pre
54b0: 74 74 79 2d 73 74 72 69 6e 67 20 70 72 65 72 65 tty-string prere
54c0: 71 2d 66 61 69 6c 73 29 0a 09 09 20 20 20 20 20 q-fails)...
54d0: 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 "\n fails:
54e0: 20 20 20 20 20 20 22 20 28 72 75 6e 73 3a 70 72 " (runs:pr
54f0: 65 74 74 79 2d 73 74 72 69 6e 67 20 66 61 69 6c etty-string fail
5500: 73 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 74 s)... "\n t
5510: 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 20 20 estmode:
5520: 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 20 20 20 " testmode...
5530: 20 20 20 22 5c 6e 20 28 6d 65 6d 62 65 72 20 27 "\n (member '
5540: 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 toplevel testmod
5550: 65 29 3a 20 22 20 28 6d 65 6d 62 65 72 20 27 74 e): " (member 't
5560: 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 oplevel testmode
5570: 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 28 6e )... "\n (n
5580: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
5590: 65 64 29 3a 20 20 20 20 22 20 28 6e 75 6c 6c 3f ed): " (null?
55a0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 0a non-completed).
55b0: 09 09 20 20 20 20 20 20 22 5c 6e 20 72 65 72 75 .. "\n reru
55c0: 6e 73 3a 20 20 20 20 20 20 20 20 20 20 22 20 72 ns: " r
55d0: 65 72 75 6e 73 0a 09 09 20 20 20 20 20 20 22 5c eruns... "\
55e0: 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 20 n items:
55f0: 20 20 20 22 20 69 74 65 6d 73 0a 09 09 20 20 20 " items...
5600: 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d "\n can-run-m
5610: 6f 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 75 ore: " can-ru
5620: 6e 2d 6d 6f 72 65 29 0a 0a 20 20 20 20 28 63 6f n-more).. (co
5630: 6e 64 0a 20 20 20 20 20 3b 3b 20 61 6c 6c 20 70 nd. ;; all p
5640: 72 65 72 65 71 73 20 6d 65 74 2c 20 66 69 72 65 rereqs met, fire
5650: 20 6f 66 66 20 74 68 65 20 74 65 73 74 0a 20 20 off the test.
5660: 20 20 20 3b 3b 20 6f 72 2c 20 69 66 20 69 74 20 ;; or, if it
5670: 69 73 20 61 20 27 74 6f 70 6c 65 76 65 6c 20 74 is a 'toplevel t
5680: 65 73 74 20 61 6e 64 20 61 6c 6c 20 70 72 65 72 est and all prer
5690: 65 71 73 20 6e 6f 74 20 6d 65 74 20 61 72 65 20 eqs not met are
56a0: 43 4f 4d 50 4c 45 54 45 44 20 74 68 65 6e 20 6c COMPLETED then l
56b0: 61 75 6e 63 68 0a 0a 20 20 20 20 20 28 28 61 6e aunch.. ((an
56c0: 64 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 27 d (not (member '
56d0: 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 toplevel testmod
56e0: 65 29 29 0a 09 20 20 20 28 6d 65 6d 62 65 72 20 e)).. (member
56f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
5700: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 default test-reg
5710: 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d istry (db:test-m
5720: 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 68 65 ake-full-name he
5730: 64 20 69 74 65 6d 2d 70 61 74 68 29 20 27 6e 2f d item-path) 'n/
5740: 61 29 0a 09 09 20 20 20 27 28 44 4f 4e 4f 54 52 a)... '(DONOTR
5750: 55 4e 20 72 65 6d 6f 76 65 64 20 43 41 4e 4e 4f UN removed CANNO
5760: 54 52 55 4e 29 29 29 20 3b 3b 20 2a 63 6f 6d 6d TRUN))) ;; *comm
5770: 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 on:cant-run-stat
5780: 65 73 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 43 4f es-sym*) ;; '(CO
5790: 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 MPLETED KILLED W
57a0: 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e AIVED UNKNOWN IN
57b0: 43 4f 4d 50 4c 45 54 45 29 29 20 3b 3b 20 74 72 COMPLETE)) ;; tr
57c0: 79 20 74 6f 20 63 61 74 63 68 20 72 65 70 65 61 y to catch repea
57d0: 74 20 70 72 6f 63 65 73 73 69 6e 67 20 6f 66 20 t processing of
57e0: 43 4f 4d 50 4c 45 54 45 44 20 74 65 73 74 73 20 COMPLETED tests
57f0: 68 65 72 65 0a 20 20 20 20 20 20 28 64 65 62 75 here. (debu
5800: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
5810: 54 65 73 74 20 22 20 68 65 64 20 22 20 73 65 74 Test " hed " set
5820: 20 74 6f 20 5c 22 22 20 28 68 61 73 68 2d 74 61 to \"" (hash-ta
5830: 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 67 ble-ref test-reg
5840: 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d istry (db:test-m
5850: 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 68 65 ake-full-name he
5860: 64 20 69 74 65 6d 2d 70 61 74 68 29 29 20 22 5c d item-path)) "\
5870: 22 2e 20 52 65 6d 6f 76 69 6e 67 20 69 74 20 66 ". Removing it f
5880: 72 6f 6d 20 74 68 65 20 71 75 65 75 65 22 29 0a rom the queue").
5890: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
58a0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
58b0: 09 20 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c . (not (nul
58c0: 6c 3f 20 72 65 67 29 29 29 0a 09 20 20 28 6c 69 l? reg))).. (li
58d0: 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e st (runs:queue-n
58e0: 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 ext-hed tal reg
58f0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
5900: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
5910: 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 xt-tal tal reg r
5920: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
5930: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
5940: 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 t-reg tal reg re
5950: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
5960: 72 65 72 75 6e 73 29 0a 09 20 20 28 62 65 67 69 reruns).. (begi
5970: 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 n.. (debug:pr
5980: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4e 6f 74 68 int-info 0 "Noth
5990: 69 6e 67 20 6c 65 66 74 20 69 6e 20 74 68 65 20 ing left in the
59a0: 71 75 65 75 65 21 22 29 0a 09 20 20 20 20 3b 3b queue!").. ;;
59b0: 20 49 66 20 67 65 74 20 68 65 72 65 20 74 77 69 If get here twi
59c0: 63 65 20 74 68 65 6e 20 77 65 20 6b 6e 6f 77 20 ce then we know
59d0: 77 65 27 76 65 20 74 72 69 65 64 20 74 6f 20 65 we've tried to e
59e0: 78 70 61 6e 64 20 61 6c 6c 20 69 74 65 6d 73 0a xpand all items.
59f0: 09 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 74 68 . ;; since th
5a00: 65 72 65 20 6d 75 73 74 20 62 65 20 61 20 6c 6f ere must be a lo
5a10: 67 69 63 20 69 73 73 75 65 20 77 69 74 68 20 74 gic issue with t
5a20: 68 65 20 68 61 6e 64 6c 69 6e 67 20 6f 66 20 6c he handling of l
5a30: 6f 6f 70 73 20 69 6e 20 74 68 65 20 0a 09 20 20 oops in the ..
5a40: 20 20 3b 3b 20 69 74 65 6d 73 20 65 78 70 61 6e ;; items expan
5a50: 64 20 70 68 61 73 65 20 77 65 20 77 69 6c 6c 20 d phase we will
5a60: 62 72 75 74 65 20 66 6f 72 63 65 20 61 6e 20 65 brute force an e
5a70: 78 69 74 20 68 65 72 65 2e 0a 09 20 20 20 20 28 xit here... (
5a80: 69 66 20 28 3e 20 72 75 6e 73 3a 6e 6f 74 68 69 if (> runs:nothi
5a90: 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 65 75 65 ng-left-in-queue
5aa0: 2d 63 6f 75 6e 74 20 32 29 0a 09 09 28 62 65 67 -count 2)...(beg
5ab0: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
5ac0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
5ad0: 74 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 20 69 this condition i
5ae0: 73 20 74 72 69 67 67 65 72 65 64 20 77 68 65 6e s triggered when
5af0: 20 74 68 65 72 65 20 77 65 72 65 20 6e 6f 20 69 there were no i
5b00: 74 65 6d 73 20 74 6f 20 65 78 70 61 6e 64 20 61 tems to expand a
5b10: 6e 64 20 6e 6f 74 68 69 6e 67 20 74 6f 20 72 75 nd nothing to ru
5b20: 6e 2e 20 50 6c 65 61 73 65 20 63 68 65 63 6b 20 n. Please check
5b30: 79 6f 75 72 20 72 75 6e 20 66 6f 72 20 63 6f 6d your run for com
5b40: 70 6c 65 74 65 6e 65 73 73 22 29 0a 09 09 20 20 pleteness")...
5b50: 28 65 78 69 74 20 30 29 29 0a 09 09 28 73 65 74 (exit 0))...(set
5b60: 21 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c ! runs:nothing-l
5b70: 65 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 eft-in-queue-cou
5b80: 6e 74 20 28 2b 20 72 75 6e 73 3a 6e 6f 74 68 69 nt (+ runs:nothi
5b90: 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 65 75 65 ng-left-in-queue
5ba0: 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 20 20 20 -count 1)))..
5bb0: 20 23 66 29 29 29 0a 0a 20 20 20 20 20 3b 3b 20 #f))).. ;;
5bc0: 0a 20 20 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c . ((or (null
5bd0: 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 ? prereqs-not-me
5be0: 74 29 0a 09 20 20 28 61 6e 64 20 28 6d 65 6d 62 t).. (and (memb
5bf0: 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 er 'toplevel tes
5c00: 74 6d 6f 64 65 29 0a 09 20 20 20 20 20 20 20 28 tmode).. (
5c10: 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 null? non-comple
5c20: 74 65 64 29 29 29 0a 20 20 20 20 20 20 28 64 65 ted))). (de
5c30: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
5c40: 20 22 72 75 6e 73 3a 65 78 70 61 6e 64 2d 69 74 "runs:expand-it
5c50: 65 6d 73 3a 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 ems: (or (null?
5c60: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
5c70: 20 28 61 6e 64 20 28 6d 65 6d 62 65 72 20 27 74 (and (member 't
5c80: 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 oplevel testmode
5c90: 29 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 )(null? non-comp
5ca0: 6c 65 74 65 64 29 29 29 22 29 0a 20 20 20 20 20 leted)))").
5cb0: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d (let ((test-nam
5cc0: 65 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 e (tests:testque
5cd0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
5ce0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 test-record)))..
5cf0: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (setenv "MT_TEST
5d00: 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 _NAME" test-name
5d10: 29 20 3b 3b 20 0a 09 28 73 65 74 65 6e 76 20 22 ) ;; ..(setenv "
5d20: 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 MT_RUNNAME" ru
5d30: 6e 6e 61 6d 65 29 0a 09 28 72 75 6e 73 3a 73 65 nname)..(runs:se
5d40: 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 t-megatest-env-v
5d50: 61 72 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e ars run-id inrun
5d60: 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b name: runname) ;
5d70: 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e ; these may be n
5d80: 65 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 eeded by the lau
5d90: 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 09 nching process..
5da0: 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 (let ((items-lis
5db0: 74 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 t (items:get-ite
5dc0: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 ms-from-config t
5dd0: 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 28 69 66 config))).. (if
5de0: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c 69 (list? items-li
5df0: 73 74 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 st).. (begi
5e00: 6e 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 69 n...(if (null? i
5e10: 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 20 20 20 tems-list)...
5e20: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 (let ((test-id
5e30: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
5e40: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5e50: 65 20 22 22 29 29 29 0a 09 09 20 20 20 20 20 20 e "")))...
5e60: 28 69 66 20 74 65 73 74 2d 69 64 20 28 6d 74 3a (if test-id (mt:
5e70: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
5e80: 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d tatus-by-id run-
5e90: 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f id test-id "NOT_
5ea0: 53 54 41 52 54 45 44 22 20 22 5a 45 52 4f 5f 49 STARTED" "ZERO_I
5eb0: 54 45 4d 53 22 20 22 46 61 69 6c 65 64 20 74 6f TEMS" "Failed to
5ec0: 20 72 75 6e 20 64 75 65 20 74 6f 20 66 61 69 6c run due to fail
5ed0: 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 73 ed prerequisites
5ee0: 22 29 29 29 29 0a 09 09 28 74 65 73 74 73 3a 74 "))))...(tests:t
5ef0: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
5f00: 6d 73 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ms! test-record
5f10: 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 28 6c items-list)...(l
5f20: 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 ist hed tal reg
5f30: 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 reruns))..
5f40: 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 3a (begin...(debug:
5f50: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
5f60: 54 68 65 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 The proc from re
5f70: 61 64 69 6e 67 20 74 68 65 20 69 74 65 6d 73 20 ading the items
5f80: 74 61 62 6c 65 20 64 69 64 20 6e 6f 74 20 79 69 table did not yi
5f90: 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 eld a list - ple
5fa0: 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 ase report this"
5fb0: 29 0a 09 09 28 65 78 69 74 20 31 29 29 29 29 29 )...(exit 1)))))
5fc0: 29 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e ).. ((and (n
5fd0: 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 20 20 20 ull? fails)..
5fe0: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 2d 66 61 (null? prereq-fa
5ff0: 69 6c 73 29 0a 09 20 20 20 28 6e 6f 74 20 28 6e ils).. (not (n
6000: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
6010: 65 64 29 29 29 0a 20 20 20 20 20 20 28 6c 65 74 ed))). (let
6020: 2a 20 28 28 61 6c 6c 69 6e 71 75 65 75 65 20 28 * ((allinqueue (
6030: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 map (lambda (x)(
6040: 69 66 20 28 73 74 72 69 6e 67 3f 20 78 29 20 78 if (string? x) x
6050: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
6060: 73 74 6e 61 6d 65 20 78 29 29 29 0a 20 20 20 20 stname x))).
6070: 20 20 20 20 09 09 20 20 20 20 20 20 28 61 70 70 .. (app
6080: 65 6e 64 20 6e 65 77 74 61 6c 20 72 65 72 75 6e end newtal rerun
6090: 73 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 70 72 s))).. ;; pr
60a0: 65 72 65 71 73 74 72 73 20 69 73 20 61 20 6c 69 ereqstrs is a li
60b0: 73 74 20 6f 66 20 74 65 73 74 20 6e 61 6d 65 73 st of test names
60c0: 20 61 73 20 73 74 72 69 6e 67 73 20 74 68 61 74 as strings that
60d0: 20 61 72 65 20 70 72 65 72 65 71 73 20 66 6f 72 are prereqs for
60e0: 20 68 65 64 0a 20 20 20 20 20 20 20 20 20 20 20 hed.
60f0: 20 20 28 70 72 65 72 65 71 73 74 72 73 20 28 64 (prereqstrs (d
6100: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
6110: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
6120: 29 28 69 66 20 28 73 74 72 69 6e 67 3f 20 78 29 )(if (string? x)
6130: 20 78 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d x (db:test-get-
6140: 74 65 73 74 6e 61 6d 65 20 78 29 29 29 0a 09 09 testname x)))...
6150: 09 09 09 09 20 70 72 65 72 65 71 73 2d 6e 6f 74 .... prereqs-not
6160: 2d 6d 65 74 29 29 29 0a 09 20 20 20 20 20 3b 3b -met))).. ;;
6170: 20 61 20 70 72 65 72 65 71 20 74 68 61 74 20 69 a prereq that i
6180: 73 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 61 s not found in a
6190: 6c 6c 69 6e 71 75 65 75 65 20 77 69 6c 6c 20 62 llinqueue will b
61a0: 65 20 70 75 74 20 69 6e 20 74 68 65 20 6e 6f 74 e put in the not
61b0: 69 6e 71 75 65 75 65 20 6c 69 73 74 0a 09 20 20 inqueue list..
61c0: 20 20 20 3b 3b 20 0a 20 20 20 20 20 20 20 20 20 ;; .
61d0: 20 20 20 20 3b 3b 20 28 6e 6f 74 69 6e 71 75 65 ;; (notinque
61e0: 75 65 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ue (filter (lamb
61f0: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 da (x).
6200: 20 20 20 20 3b 3b 20 20 20 20 09 09 20 20 20 28 ;; .. (
6210: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 78 20 61 6c not (member x al
6220: 6c 69 6e 71 75 65 75 65 29 29 29 0a 20 20 20 20 linqueue))).
6230: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 09 ;; .
6240: 09 20 70 72 65 72 65 71 73 74 72 73 29 29 0a 09 . prereqstrs))..
6250: 20 20 20 20 20 28 67 69 76 65 2d 75 70 20 20 20 (give-up
6260: 20 23 66 29 29 0a 0a 09 3b 3b 20 57 65 20 63 61 #f))...;; We ca
6270: 6e 20 67 65 74 20 68 65 72 65 20 77 68 65 6e 20 n get here when
6280: 61 20 70 72 65 72 65 71 20 68 61 73 20 6e 6f 74 a prereq has not
6290: 20 62 65 65 6e 20 72 75 6e 20 64 75 65 20 74 6f been run due to
62a0: 20 2a 69 74 2a 20 68 61 76 69 6e 67 20 61 20 70 *it* having a p
62b0: 72 65 72 65 71 20 74 68 61 74 20 66 61 69 6c 65 rereq that faile
62c0: 64 2e 0a 09 3b 3b 20 57 65 20 6e 65 65 64 20 74 d...;; We need t
62d0: 6f 20 75 73 65 20 74 68 69 73 20 74 6f 20 64 65 o use this to de
62e0: 71 75 65 75 65 20 74 68 69 73 20 69 74 65 6d 20 queue this item
62f0: 61 73 20 43 41 4e 4e 4f 54 52 55 4e 0a 09 3b 3b as CANNOTRUN..;;
6300: 20 0a 09 28 69 66 20 28 6d 65 6d 62 65 72 20 74 ..(if (member t
6310: 65 73 74 6d 6f 64 65 20 27 28 74 6f 70 6c 65 76 estmode '(toplev
6320: 65 6c 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 el)).. (for-e
6330: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 72 65 ach (lambda (pre
6340: 72 65 71 29 0a 09 09 09 28 69 66 20 28 65 71 3f req)....(if (eq?
6350: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6360: 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 /default test-re
6370: 67 69 73 74 72 79 20 70 72 65 72 65 71 20 27 6a gistry prereq 'j
6380: 75 73 74 66 69 6e 65 29 20 27 43 41 4e 4e 4f 54 ustfine) 'CANNOT
6390: 52 55 4e 29 0a 09 09 09 20 20 20 20 28 73 65 74 RUN).... (set
63a0: 21 20 67 69 76 65 2d 75 70 20 23 74 29 29 29 0a ! give-up #t))).
63b0: 09 09 20 20 20 20 20 20 70 72 65 72 65 71 73 74 .. prereqst
63c0: 72 73 29 29 0a 0a 09 28 69 66 20 28 61 6e 64 20 rs))...(if (and
63d0: 67 69 76 65 2d 75 70 0a 09 09 20 28 6e 6f 74 20 give-up... (not
63e0: 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (and (null? tal)
63f0: 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 29 0a 09 (null? reg))))..
6400: 20 20 20 20 28 6c 65 74 20 28 28 74 72 69 6d 6d (let ((trimm
6410: 65 64 2d 74 61 6c 20 28 6d 74 3a 64 69 73 63 61 ed-tal (mt:disca
6420: 72 64 2d 62 6c 6f 63 6b 65 64 2d 74 65 73 74 73 rd-blocked-tests
6430: 20 72 75 6e 2d 69 64 20 68 65 64 20 74 61 6c 20 run-id hed tal
6440: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
6450: 09 20 20 28 74 72 69 6d 6d 65 64 2d 72 65 67 20 . (trimmed-reg
6460: 28 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c 6f 63 (mt:discard-bloc
6470: 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 ked-tests run-id
6480: 20 68 65 64 20 72 65 67 20 74 65 73 74 2d 72 65 hed reg test-re
6490: 63 6f 72 64 73 29 29 29 0a 09 20 20 20 20 20 20 cords)))..
64a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
64b0: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 WARNING: test "
64c0: 68 65 64 20 22 20 68 61 73 20 64 69 73 63 61 72 hed " has discar
64d0: 64 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 ded prerequisite
64e0: 73 2c 20 72 65 6d 6f 76 69 6e 67 20 69 74 20 66 s, removing it f
64f0: 72 6f 6d 20 74 68 65 20 71 75 65 75 65 22 29 0a rom the queue").
6500: 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 .. (let ((t
6510: 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d est-id (rmt:get-
6520: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 68 test-id run-id h
6530: 65 64 20 22 22 29 29 29 0a 09 09 28 69 66 20 74 ed "")))...(if t
6540: 65 73 74 2d 69 64 20 28 6d 74 3a 74 65 73 74 2d est-id (mt:test-
6550: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
6560: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
6570: 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 st-id "NOT_START
6580: 45 44 22 20 22 50 52 45 51 5f 44 49 53 43 41 52 ED" "PREQ_DISCAR
6590: 44 45 44 22 20 22 46 61 69 6c 65 64 20 74 6f 20 DED" "Failed to
65a0: 72 75 6e 20 64 75 65 20 74 6f 20 64 69 73 63 61 run due to disca
65b0: 72 64 65 64 20 70 72 65 72 65 71 75 69 73 69 74 rded prerequisit
65c0: 65 73 22 29 29 29 0a 09 20 20 20 20 20 20 0a 09 es"))).. ..
65d0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
65e0: 6e 75 6c 6c 3f 20 74 72 69 6d 6d 65 64 2d 74 61 null? trimmed-ta
65f0: 6c 29 0a 09 09 20 20 20 20 20 20 20 28 6e 75 6c l)... (nul
6600: 6c 3f 20 74 72 69 6d 6d 65 64 2d 72 65 67 29 29 l? trimmed-reg))
6610: 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c 69 73 ... #f... (lis
6620: 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 t (runs:queue-ne
6630: 78 74 2d 68 65 64 20 74 72 69 6d 6d 65 64 2d 74 xt-hed trimmed-t
6640: 61 6c 20 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 al trimmed-reg r
6650: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
6660: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
6670: 78 74 2d 74 61 6c 20 74 72 69 6d 6d 65 64 2d 74 xt-tal trimmed-t
6680: 61 6c 20 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 al trimmed-reg r
6690: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
66a0: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
66b0: 78 74 2d 72 65 67 20 74 72 69 6d 6d 65 64 2d 74 xt-reg trimmed-t
66c0: 61 6c 20 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 al trimmed-reg r
66d0: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
66e0: 09 09 72 65 72 75 6e 73 29 29 29 0a 09 20 20 20 ..reruns)))..
66f0: 20 20 20 28 6c 69 73 74 20 28 63 61 72 20 6e 65 (list (car ne
6700: 77 74 61 6c 29 28 61 70 70 65 6e 64 20 28 63 64 wtal)(append (cd
6710: 72 20 6e 65 77 74 61 6c 29 20 72 65 67 29 20 27 r newtal) reg) '
6720: 28 29 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 20 () reruns))))..
6730: 20 20 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f ((and (null?
6740: 20 66 61 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c fails).. (nul
6750: 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 l? prereq-fails)
6760: 0a 09 20 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d .. (null? non-
6770: 63 6f 6d 70 6c 65 74 65 64 29 29 0a 20 20 20 20 completed)).
6780: 20 20 28 69 66 20 20 28 72 75 6e 73 3a 63 61 6e (if (runs:can
6790: 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 3f 20 68 -keep-running? h
67a0: 65 64 20 32 30 29 0a 09 20 20 28 62 65 67 69 6e ed 20).. (begin
67b0: 0a 09 20 20 20 20 28 72 75 6e 73 3a 69 6e 63 2d .. (runs:inc-
67c0: 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 20 68 cant-run-tests h
67d0: 65 64 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ed).. (debug:
67e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f print-info 1 "no
67f0: 20 66 61 69 6c 73 20 69 6e 20 70 72 65 72 65 71 fails in prereq
6800: 75 69 73 69 74 65 73 20 66 6f 72 20 22 20 68 65 uisites for " he
6810: 64 20 22 20 62 75 74 20 61 6c 73 6f 20 6e 6f 6e d " but also non
6820: 65 20 72 75 6e 6e 69 6e 67 2c 20 6b 65 65 70 69 e running, keepi
6830: 6e 67 20 22 20 68 65 64 20 22 20 66 6f 72 20 6e ng " hed " for n
6840: 6f 77 2e 20 54 72 79 20 63 6f 75 6e 74 3a 20 22 ow. Try count: "
6850: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6860: 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e 2d 63 /default *seen-c
6870: 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 68 ant-run-tests* h
6880: 65 64 20 30 29 29 0a 09 20 20 20 20 3b 3b 20 67 ed 0)).. ;; g
6890: 65 74 74 69 6e 67 20 68 65 72 65 20 6c 69 6b 65 etting here like
68a0: 6c 79 20 6d 65 61 6e 73 20 74 68 65 20 73 79 73 ly means the sys
68b0: 74 65 6d 20 69 73 20 77 61 79 20 6f 76 65 72 6c tem is way overl
68c0: 6f 61 64 65 64 2c 20 6b 69 6c 6c 20 61 20 66 75 oaded, kill a fu
68d0: 6c 6c 20 6d 69 6e 75 74 65 20 62 65 66 6f 72 65 ll minute before
68e0: 20 63 6f 6e 74 69 6e 75 69 6e 67 0a 09 20 20 20 continuing..
68f0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
6900: 36 30 29 0a 09 20 20 20 20 3b 3b 20 6e 75 6d 2d 60).. ;; num-
6910: 72 65 74 72 69 65 73 20 63 6f 64 65 20 77 61 73 retries code was
6920: 20 68 65 72 65 0a 09 20 20 20 20 3b 3b 20 77 65 here.. ;; we
6930: 20 75 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 use this opport
6940: 75 6e 69 74 79 20 74 6f 20 6d 6f 76 65 20 63 6f unity to move co
6950: 6e 74 65 6e 74 73 20 6f 66 20 72 65 67 20 74 6f ntents of reg to
6960: 20 74 61 6c 0a 09 20 20 20 20 28 6c 69 73 74 20 tal.. (list
6970: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 (car newtal)(app
6980: 65 6e 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 end (cdr newtal)
6990: 20 72 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 reg) '() reruns
69a0: 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 20 77 )) ;; an issue w
69b0: 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f 74 20 ith prereqs not
69c0: 79 65 74 20 6d 65 74 3f 0a 09 20 20 28 62 65 67 yet met?.. (beg
69d0: 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 in.. (debug:p
69e0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 rint-info 1 "no
69f0: 66 61 69 6c 73 20 69 6e 20 70 72 65 72 65 71 75 fails in prerequ
6a00: 69 73 69 74 65 73 20 66 6f 72 20 22 20 68 65 64 isites for " hed
6a10: 20 22 20 62 75 74 20 6e 6f 74 68 69 6e 67 20 73 " but nothing s
6a20: 65 65 6e 20 72 75 6e 6e 69 6e 67 20 69 6e 20 61 een running in a
6a30: 20 77 68 69 6c 65 2c 20 64 72 6f 70 70 69 6e 67 while, dropping
6a40: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 66 72 test " hed " fr
6a50: 6f 6d 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 om the run queue
6a60: 22 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 ").. (let ((t
6a70: 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d est-id (rmt:get-
6a80: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 68 test-id run-id h
6a90: 65 64 20 22 22 29 29 29 0a 09 20 20 20 20 20 20 ed "")))..
6aa0: 28 69 66 20 74 65 73 74 2d 69 64 20 28 6d 74 3a (if test-id (mt:
6ab0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
6ac0: 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d tatus-by-id run-
6ad0: 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f id test-id "NOT_
6ae0: 53 54 41 52 54 45 44 22 20 22 54 49 4d 45 44 5f STARTED" "TIMED_
6af0: 4f 55 54 22 20 22 4e 6f 74 68 69 6e 67 20 73 65 OUT" "Nothing se
6b00: 65 6e 20 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 en running in a
6b10: 77 68 69 6c 65 2e 22 29 29 29 0a 09 20 20 20 20 while.")))..
6b20: 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 (list (runs:queu
6b30: 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 e-next-hed tal r
6b40: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6b50: 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 l)... (runs:que
6b60: 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 ue-next-tal tal
6b70: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
6b80: 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 ll)... (runs:qu
6b90: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
6ba0: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
6bb0: 75 6c 6c 29 0a 09 09 20 20 72 65 72 75 6e 73 29 ull)... reruns)
6bc0: 29 29 29 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 ))).. ((and
6bd0: 0a 20 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 . (or (not
6be0: 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 0a (null? fails)).
6bf0: 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 . (not (null?
6c00: 70 72 65 72 65 71 2d 66 61 69 6c 73 29 29 29 0a prereq-fails))).
6c10: 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 27 (member '
6c20: 6e 6f 72 6d 61 6c 20 74 65 73 74 6d 6f 64 65 29 normal testmode)
6c30: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
6c40: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 74 65 73 rint-info 1 "tes
6c50: 74 20 22 20 20 68 65 64 20 22 20 28 6d 6f 64 65 t " hed " (mode
6c60: 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 29 20 68 =" testmode ") h
6c70: 61 73 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 as failed prereq
6c80: 75 69 73 69 74 65 28 73 29 3b 20 22 0a 09 09 09 uisite(s); "....
6c90: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
6ca0: 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 rse (map (lambda
6cb0: 20 28 74 29 28 63 6f 6e 63 20 28 64 62 3a 74 65 (t)(conc (db:te
6cc0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
6cd0: 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d t) ":" (db:test-
6ce0: 67 65 74 2d 73 74 61 74 65 20 74 29 22 2f 22 28 get-state t)"/"(
6cf0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
6d00: 75 73 20 74 29 29 29 20 66 61 69 6c 73 29 20 22 us t))) fails) "
6d10: 2c 20 22 29 0a 09 09 09 22 2c 20 72 65 6d 6f 76 , ")....", remov
6d20: 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 ing it from to-d
6d30: 6f 20 6c 69 73 74 22 29 0a 20 20 20 20 20 20 28 o list"). (
6d40: 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 let ((test-id (r
6d50: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
6d60: 75 6e 2d 69 64 20 68 65 64 20 22 22 29 29 29 0a un-id hed ""))).
6d70: 09 28 69 66 20 74 65 73 74 2d 69 64 0a 09 20 20 .(if test-id..
6d80: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
6d90: 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 29 29 ? prereq-fails))
6da0: 0a 09 09 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d ...(mt:test-set-
6db0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
6dc0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
6dd0: 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 d "NOT_STARTED"
6de0: 22 50 52 45 51 5f 44 49 53 43 41 52 44 45 44 22 "PREQ_DISCARDED"
6df0: 20 22 46 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 "Failed to run
6e00: 64 75 65 20 74 6f 20 70 72 69 6f 72 20 66 61 69 due to prior fai
6e10: 6c 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 led prerequisite
6e20: 73 22 29 0a 09 09 28 6d 74 3a 74 65 73 74 2d 73 s")...(mt:test-s
6e30: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
6e40: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
6e50: 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 t-id "NOT_STARTE
6e60: 44 22 20 22 50 52 45 51 5f 46 41 49 4c 22 20 20 D" "PREQ_FAIL"
6e70: 20 20 20 20 22 46 61 69 6c 65 64 20 74 6f 20 72 "Failed to r
6e80: 75 6e 20 64 75 65 20 74 6f 20 66 61 69 6c 65 64 un due to failed
6e90: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 22 29 prerequisites")
6ea0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f ))). (if (o
6eb0: 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 r (not (null? re
6ec0: 67 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 g))(not (null? t
6ed0: 61 6c 29 29 29 0a 09 20 20 28 62 65 67 69 6e 0a al))).. (begin.
6ee0: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
6ef0: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
6f00: 74 72 79 20 68 65 64 20 27 43 41 4e 4e 4f 54 52 try hed 'CANNOTR
6f10: 55 4e 29 0a 09 20 20 20 20 28 6c 69 73 74 20 28 UN).. (list (
6f20: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
6f30: 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c hed tal reg regl
6f40: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 en regfull)...
6f50: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
6f60: 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 65 67 -tal tal reg reg
6f70: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 len regfull)...
6f80: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
6f90: 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 t-reg tal reg re
6fa0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
6fb0: 20 20 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 (cons hed reru
6fc0: 6e 73 29 29 29 0a 09 20 20 23 66 29 29 20 3b 3b ns))).. #f)) ;;
6fd0: 20 23 66 20 66 6c 61 67 73 20 64 6f 20 6e 6f 74 #f flags do not
6fe0: 20 6c 6f 6f 70 0a 0a 20 20 20 20 20 28 28 61 6e loop.. ((an
6ff0: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 d (not (null? fa
7000: 69 6c 73 29 29 28 6d 65 6d 62 65 72 20 27 74 6f ils))(member 'to
7010: 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 plevel testmode)
7020: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 ). (if (or
7030: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
7040: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
7050: 29 29 29 0a 09 20 20 20 28 6c 69 73 74 20 28 63 ))).. (list (c
7060: 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e ar newtal)(appen
7070: 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 d (cdr newtal) r
7080: 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 0a eg) '() reruns).
7090: 09 20 20 23 66 29 29 20 0a 20 20 20 20 20 28 28 . #f)) . ((
70a0: 6e 75 6c 6c 3f 20 72 75 6e 6e 61 62 6c 65 73 29 null? runnables)
70b0: 20 23 66 29 20 3b 3b 20 69 66 20 77 65 20 67 65 #f) ;; if we ge
70c0: 74 20 68 65 72 65 20 61 6e 64 20 6e 6f 6e 2d 63 t here and non-c
70d0: 6f 6d 70 6c 65 74 65 64 20 69 73 20 6e 75 6c 6c ompleted is null
70e0: 20 74 68 65 20 69 74 27 73 20 61 6c 6c 20 6f 76 the it's all ov
70f0: 65 72 2e 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 er.. (else.
7100: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7110: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 46 41 t 0 "WARNING: FA
7120: 49 4c 53 20 6f 72 20 69 6e 63 6f 6d 70 6c 65 74 ILS or incomplet
7130: 65 20 74 65 73 74 73 20 6d 61 79 62 65 20 70 72 e tests maybe pr
7140: 65 76 65 6e 74 69 6e 67 20 63 6f 6d 70 6c 65 74 eventing complet
7150: 69 6f 6e 20 6f 66 20 74 68 69 73 20 72 75 6e 2e ion of this run.
7160: 20 57 61 74 63 68 20 66 6f 72 20 69 73 73 75 65 Watch for issue
7170: 73 20 77 69 74 68 20 74 65 73 74 20 22 20 68 65 s with test " he
7180: 64 20 22 2c 20 63 6f 6e 74 69 6e 75 69 6e 67 20 d ", continuing
7190: 66 6f 72 20 6e 6f 77 22 29 0a 20 20 20 20 20 20 for now").
71a0: 3b 3b 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 ;; (list (runs:q
71b0: 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 ueue-next-hed ta
71c0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
71d0: 66 75 6c 6c 29 0a 20 20 20 20 20 20 3b 3b 20 20 full). ;;
71e0: 20 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 .(runs:queue-ne
71f0: 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 xt-tal tal reg r
7200: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 eglen regfull).
7210: 20 20 20 20 20 3b 3b 20 20 20 09 28 72 75 6e 73 ;; .(runs
7220: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
7230: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
7240: 65 67 66 75 6c 6c 29 0a 20 20 20 20 20 20 3b 3b egfull). ;;
7250: 20 20 20 09 72 65 72 75 6e 73 29 0a 20 20 20 20 .reruns).
7260: 20 20 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 (list (car new
7270: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
7280: 20 72 65 67 20 72 65 72 75 6e 73 29 29 29 29 29 reg reruns)))))
7290: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
72a0: 6d 69 78 65 64 2d 6c 69 73 74 2d 74 65 73 74 6e mixed-list-testn
72b0: 61 6d 65 2d 61 6e 64 2d 74 65 73 74 72 65 63 2d ame-and-testrec-
72c0: 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 69 6e 67 73 >list-of-strings
72d0: 20 69 6e 6c 73 74 29 0a 20 20 28 69 66 20 28 6e inlst). (if (n
72e0: 75 6c 6c 3f 20 69 6e 6c 73 74 29 0a 20 20 20 20 ull? inlst).
72f0: 20 20 27 28 29 0a 20 20 20 20 20 20 28 6d 61 70 '(). (map
7300: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 20 (lambda (t)..
7310: 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 (cond..
7320: 28 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 20 20 ((vector? t)..
7330: 20 20 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 (let ((test
7340: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
7350: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 29 0a et-testname t)).
7360: 09 09 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 .. (item-pat
7370: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
7380: 74 65 6d 2d 70 61 74 68 20 74 29 29 0a 09 09 20 tem-path t))...
7390: 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 65 20 (test-state
73a0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
73b0: 74 65 20 74 29 29 0a 09 09 20 20 20 20 20 28 74 te t))... (t
73c0: 65 73 74 2d 73 74 61 74 75 73 20 28 64 62 3a 74 est-status (db:t
73d0: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 est-get-status t
73e0: 29 29 29 0a 09 09 20 28 63 6f 6e 63 20 74 65 73 )))... (conc tes
73f0: 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 t-name (if (equa
7400: 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 l? item-path "")
7410: 20 22 22 20 22 2f 22 29 20 69 74 65 6d 2d 70 61 "" "/") item-pa
7420: 74 68 20 22 3a 22 20 74 65 73 74 2d 73 74 61 74 th ":" test-stat
7430: 65 20 22 2f 22 20 74 65 73 74 2d 73 74 61 74 75 e "/" test-statu
7440: 73 29 29 29 0a 09 20 20 20 20 20 20 28 28 73 74 s))).. ((st
7450: 72 69 6e 67 3f 20 74 29 0a 09 20 20 20 20 20 20 ring? t)..
7460: 20 74 29 0a 09 20 20 20 20 20 20 28 65 6c 73 65 t).. (else
7470: 20 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 63 20 .. (conc
7480: 74 29 29 29 29 0a 09 20 20 20 69 6e 6c 73 74 29 t)))).. inlst)
7490: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
74a0: 73 3a 70 72 6f 63 65 73 73 2d 65 78 70 61 6e 64 s:process-expand
74b0: 65 64 2d 74 65 73 74 73 20 68 65 64 20 74 61 6c ed-tests hed tal
74c0: 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 67 6c reg reruns regl
74d0: 65 6e 20 72 65 67 66 75 6c 6c 20 74 65 73 74 2d en regfull test-
74e0: 72 65 63 6f 72 64 20 72 75 6e 6e 61 6d 65 20 74 record runname t
74f0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7500: 74 68 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d th jobgroup max-
7510: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
7520: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 run-id waitons i
7530: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f 64 tem-path testmod
7540: 65 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 71 e test-patts req
7550: 75 69 72 65 64 2d 74 65 73 74 73 20 74 65 73 74 uired-tests test
7560: 2d 72 65 67 69 73 74 72 79 20 72 65 67 69 73 74 -registry regist
7570: 72 79 2d 6d 75 74 65 78 20 66 6c 61 67 73 20 6b ry-mutex flags k
7580: 65 79 76 61 6c 73 20 72 75 6e 2d 69 6e 66 6f 20 eyvals run-info
7590: 6e 65 77 74 61 6c 20 61 6c 6c 2d 74 65 73 74 73 newtal all-tests
75a0: 2d 72 65 67 69 73 74 72 79 20 69 74 65 6d 6d 61 -registry itemma
75b0: 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e p). (let* ((run
75c0: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 20 20 20 -limits-info
75d0: 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 (runs:can-r
75e0: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 75 un-more-tests ru
75f0: 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 20 6d 61 n-id jobgroup ma
7600: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
7610: 73 29 29 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 s)) ;; look at t
7620: 68 65 20 74 65 73 74 20 6a 6f 62 67 72 6f 75 70 he test jobgroup
7630: 20 61 6e 64 20 74 6f 74 20 6a 6f 62 73 20 72 75 and tot jobs ru
7640: 6e 6e 69 6e 67 0a 09 20 28 68 61 76 65 2d 72 65 nning.. (have-re
7650: 73 6f 75 72 63 65 73 20 20 20 20 20 20 20 20 20 sources
7660: 20 28 63 61 72 20 72 75 6e 2d 6c 69 6d 69 74 73 (car run-limits
7670: 2d 69 6e 66 6f 29 29 0a 09 20 28 6e 75 6d 2d 72 -info)).. (num-r
7680: 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 unning
7690: 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e (list-ref run
76a0: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 31 29 29 -limits-info 1))
76b0: 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d .. (num-running-
76c0: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 6c 69 73 in-jobgroup (lis
76d0: 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 t-ref run-limits
76e0: 2d 69 6e 66 6f 20 32 29 29 20 0a 09 20 28 6d 61 -info 2)) .. (ma
76f0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
7700: 73 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 s (list-ref
7710: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 run-limits-info
7720: 33 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 3)).. (job-group
7730: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit (
7740: 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d list-ref run-lim
7750: 69 74 73 2d 69 6e 66 6f 20 34 29 29 0a 09 20 28 its-info 4)).. (
7760: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
7770: 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 (rmt:get
7780: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
7790: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
77a0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f item-path testmo
77b0: 64 65 20 69 74 65 6d 6d 61 70 3a 20 69 74 65 6d de itemmap: item
77c0: 6d 61 70 29 29 0a 09 20 3b 3b 20 28 70 72 65 72 map)).. ;; (prer
77d0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 20 20 20 20 eqs-not-met
77e0: 20 20 20 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 (mt:lazy-get
77f0: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
7800: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
7810: 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 item-path mode:
7820: 74 65 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 70 testmode itemmap
7830: 3a 20 69 74 65 6d 6d 61 70 29 29 0a 09 20 28 66 : itemmap)).. (f
7840: 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 20 ails
7850: 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c (runs:cal
7860: 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d c-fails prereqs-
7870: 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 6e 6f 6e not-met)).. (non
7880: 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 20 20 20 -completed
7890: 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d (runs:calc-
78a0: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
78b0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
78c0: 09 20 28 6c 6f 6f 70 2d 6c 69 73 74 20 20 20 20 . (loop-list
78d0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
78e0: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
78f0: 75 6e 73 29 29 0a 09 20 3b 3b 20 63 6f 6e 66 69 uns)).. ;; confi
7900: 67 75 72 65 20 74 68 65 20 6c 6f 61 64 20 72 75 gure the load ru
7910: 6e 6e 65 72 0a 09 20 28 6e 75 6d 63 70 75 73 20 nner.. (numcpus
7920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7930: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d (common:get-num-
7940: 63 70 75 73 29 29 0a 09 20 28 6d 61 78 6c 6f 61 cpus)).. (maxloa
7950: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d
7960: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
7970: 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c r (or (configf:l
7980: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
7990: 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 * "jobtools" "ma
79a0: 78 6c 6f 61 64 22 29 20 22 33 22 29 29 29 0a 09 xload") "3")))..
79b0: 20 28 77 61 69 74 64 65 6c 61 79 20 20 20 20 20 (waitdelay
79c0: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
79d0: 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 g->number (or (c
79e0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
79f0: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f onfigdat* "jobto
7a00: 6f 6c 73 22 20 22 77 61 69 74 64 65 6c 61 79 22 ols" "waitdelay"
7a10: 29 20 22 36 30 22 29 29 29 29 0a 20 20 20 20 28 ) "60")))). (
7a20: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7a30: 20 34 20 22 68 61 76 65 2d 72 65 73 6f 75 72 63 4 "have-resourc
7a40: 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f 75 es: " have-resou
7a50: 72 63 65 73 20 22 20 70 72 65 72 65 71 73 2d 6e rces " prereqs-n
7a60: 6f 74 2d 6d 65 74 3a 20 28 22 20 0a 09 09 20 20 ot-met: (" ...
7a70: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
7a80: 72 73 70 65 72 73 65 20 0a 09 09 20 20 20 20 20 rsperse ...
7a90: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
7aa0: 74 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 t).... (if
7ab0: 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 (vector? t).....
7ac0: 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 (conc (db:test
7ad0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
7ae0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
7af0: 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 20 20 tatus t)).....
7b00: 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a (conc " WARNING:
7b10: 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 t is not a vect
7b20: 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 20 20 or=" t )))....
7b30: 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 prereqs-not-me
7b40: 74 29 20 22 2c 20 22 29 20 22 29 20 66 61 69 6c t) ", ") ") fail
7b50: 73 3a 20 22 20 66 61 69 6c 73 29 0a 20 20 20 20 s: " fails).
7b60: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e . (if (and (n
7b70: 6f 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 ot (null? prereq
7b80: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 20 20 s-not-met))..
7b90: 20 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 (runs:lownoise
7ba0: 20 28 63 6f 6e 63 20 22 77 61 69 74 69 6e 67 20 (conc "waiting
7bb0: 6f 6e 20 74 65 73 74 73 20 22 20 70 72 65 72 65 on tests " prere
7bc0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 68 65 64 29 20 qs-not-met hed)
7bd0: 36 30 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 60))..(debug:pri
7be0: 6e 74 2d 69 6e 66 6f 20 32 20 22 77 61 69 74 69 nt-info 2 "waiti
7bf0: 6e 67 20 6f 6e 20 74 65 73 74 73 3b 20 22 20 28 ng on tests; " (
7c00: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7c10: 73 65 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c se (runs:mixed-l
7c20: 69 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 ist-testname-and
7c30: 2d 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f -testrec->list-o
7c40: 66 2d 73 74 72 69 6e 67 73 20 70 72 65 72 65 71 f-strings prereq
7c50: 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 s-not-met) ", ")
7c60: 29 29 0a 0a 20 20 20 20 3b 3b 20 44 6f 6e 27 74 )).. ;; Don't
7c70: 20 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 74 69 know at this ti
7c80: 6d 65 20 69 66 20 74 68 65 20 74 65 73 74 20 68 me if the test h
7c90: 61 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 ave been launche
7ca0: 64 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 d at some time i
7cb0: 6e 20 74 68 65 20 70 61 73 74 0a 20 20 20 20 3b n the past. ;
7cc0: 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 61 ; i.e. is this a
7cd0: 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 20 20 20 20 re-launch?.
7ce0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7cf0: 6f 20 34 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d o 4 "run-limits-
7d00: 69 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d info = " run-lim
7d10: 69 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 0a 20 its-info). .
7d20: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 0a 20 (cond. .
7d30: 20 20 20 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 ;; Check ite
7d40: 6d 20 70 61 74 68 20 61 67 61 69 6e 73 74 20 69 m path against i
7d50: 74 65 6d 2d 70 61 74 74 73 2c 20 0a 20 20 20 20 tem-patts, .
7d60: 20 3b 3b 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 ;;. ((not (
7d70: 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 tests:match test
7d80: 2d 70 61 74 74 73 20 28 74 65 73 74 73 3a 74 65 -patts (tests:te
7d90: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
7da0: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
7db0: 29 20 69 74 65 6d 2d 70 61 74 68 20 72 65 71 75 ) item-path requ
7dc0: 69 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d 74 ired: required-t
7dd0: 65 73 74 73 29 29 20 3b 3b 20 54 68 69 73 20 74 ests)) ;; This t
7de0: 65 73 74 2f 69 74 65 6d 70 61 74 68 20 69 73 20 est/itempath is
7df0: 6e 6f 74 20 74 6f 20 62 65 20 72 75 6e 0a 20 20 not to be run.
7e00: 20 20 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 ;; else the
7e10: 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 run is stuck, te
7e20: 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 mporarily or per
7e30: 6d 61 6e 65 6e 74 6c 79 0a 20 20 20 20 20 20 3b manently. ;
7e40: 3b 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 ; but should che
7e50: 63 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 ck if it is due
7e60: 74 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 to lack of resou
7e70: 72 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 rces vs. prerequ
7e80: 69 73 69 74 65 73 0a 20 20 20 20 20 20 28 64 65 isites. (de
7e90: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
7ea0: 20 22 53 6b 69 70 70 69 6e 67 20 22 20 28 74 65 "Skipping " (te
7eb0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
7ec0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
7ed0: 72 65 63 6f 72 64 29 20 22 20 22 20 69 74 65 6d record) " " item
7ee0: 2d 70 61 74 68 20 22 20 61 73 20 69 74 20 64 6f -path " as it do
7ef0: 65 73 6e 27 74 20 6d 61 74 63 68 20 22 20 74 65 esn't match " te
7f00: 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 20 20 st-patts).
7f10: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 (if (or (not (nu
7f20: 6c 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 28 6e ll? tal))(not (n
7f30: 75 6c 6c 3f 20 72 65 67 29 29 29 0a 09 20 20 28 ull? reg))).. (
7f40: 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 list (runs:queue
7f50: 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 -next-hed tal re
7f60: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
7f70: 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d )...(runs:queue-
7f80: 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 next-tal tal reg
7f90: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
7fa0: 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ...(runs:queue-n
7fb0: 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 ext-reg tal reg
7fc0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
7fd0: 09 09 72 65 72 75 6e 73 29 0a 09 20 20 23 66 29 ..reruns).. #f)
7fe0: 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 ). . ;;
7ff0: 52 65 67 69 73 74 65 72 20 74 65 73 74 73 20 0a Register tests .
8000: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 28 6e ;;. ((n
8010: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
8020: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
8030: 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 registry (db:tes
8040: 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 t-make-full-name
8050: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
8060: 70 61 74 68 29 20 23 66 29 29 0a 20 20 20 20 20 path) #f)).
8070: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8080: 66 6f 20 34 20 22 50 72 65 2d 72 65 67 69 73 74 fo 4 "Pre-regist
8090: 65 72 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 ering test " tes
80a0: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
80b0: 70 61 74 68 20 22 20 74 6f 20 63 72 65 61 74 65 path " to create
80c0: 20 70 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 0a placeholder" ).
80d0: 20 20 20 20 20 20 3b 3b 20 61 6c 77 61 79 73 20 ;; always
80e0: 64 6f 20 66 69 72 6d 20 72 65 67 69 73 74 72 61 do firm registra
80f0: 74 69 6f 6e 20 6e 6f 77 20 69 6e 20 76 31 2e 36 tion now in v1.6
8100: 30 20 61 6e 64 20 67 72 65 61 74 65 72 20 3b 3b 0 and greater ;;
8110: 20 28 65 71 3f 20 2a 74 72 61 6e 73 70 6f 72 74 (eq? *transport
8120: 2d 74 79 70 65 2a 20 27 66 73 29 20 3b 3b 20 6e -type* 'fs) ;; n
8130: 6f 20 70 6f 69 6e 74 20 69 6e 20 70 61 72 61 6c o point in paral
8140: 6c 65 6c 20 72 65 67 69 73 74 72 61 74 69 6f 6e lel registration
8150: 20 69 66 20 75 73 65 20 66 73 0a 20 20 20 20 20 if use fs.
8160: 20 28 6c 65 74 20 72 65 67 69 73 74 65 72 2d 6c (let register-l
8170: 6f 6f 70 20 28 28 6e 75 6d 74 72 69 65 73 20 31 oop ((numtries 1
8180: 35 29 29 0a 09 28 72 6d 74 3a 67 65 6e 65 72 61 5))..(rmt:genera
8190: 6c 2d 63 61 6c 6c 20 27 72 65 67 69 73 74 65 72 l-call 'register
81a0: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e -test run-id run
81b0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
81c0: 65 6d 2d 70 61 74 68 29 0a 09 28 69 66 20 28 72 em-path)..(if (r
81d0: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
81e0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
81f0: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
8200: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
8210: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
8220: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
8230: 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 l-name test-name
8240: 20 69 74 65 6d 2d 70 61 74 68 29 20 27 64 6f 6e item-path) 'don
8250: 65 29 0a 09 20 20 20 20 28 69 66 20 28 3e 20 6e e).. (if (> n
8260: 75 6d 74 72 69 65 73 20 30 29 0a 09 09 28 62 65 umtries 0)...(be
8270: 67 69 6e 0a 09 09 20 20 28 74 68 72 65 61 64 2d gin... (thread-
8280: 73 6c 65 65 70 21 20 30 2e 35 29 0a 09 09 20 20 sleep! 0.5)...
8290: 28 72 65 67 69 73 74 65 72 2d 6c 6f 6f 70 20 28 (register-loop (
82a0: 2d 20 6e 75 6d 74 72 69 65 73 20 31 29 29 29 0a - numtries 1))).
82b0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
82c0: 20 22 45 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 "ERROR: failed
82d0: 74 6f 20 72 65 67 69 73 74 65 72 20 74 65 73 74 to register test
82e0: 20 22 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 " (db:test-make
82f0: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
8300: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
8310: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e ))). (if (n
8320: 6f 74 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 ot (eq? (hash-ta
8330: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8340: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 test-registry (d
8350: 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c b:test-make-full
8360: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
8370: 22 22 29 20 23 66 29 20 27 64 6f 6e 65 29 29 0a "") #f) 'done)).
8380: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 . (begin.. (
8390: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
83a0: 20 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 'register-test
83b0: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 run-id run-id te
83c0: 73 74 2d 6e 61 6d 65 20 22 22 29 0a 09 20 20 20 st-name "")..
83d0: 20 28 69 66 20 28 72 6d 74 3a 67 65 74 2d 74 65 (if (rmt:get-te
83e0: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
83f0: 74 2d 6e 61 6d 65 20 22 22 29 0a 09 09 28 68 61 t-name "")...(ha
8400: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
8410: 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a st-registry (db:
8420: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
8430: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 ame test-name ""
8440: 29 20 27 64 6f 6e 65 29 29 29 29 0a 20 20 20 20 ) 'done)))).
8450: 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 (runs:shrink-c
8460: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
8470: 73 2d 63 6f 75 6e 74 29 20 20 20 3b 3b 20 44 45 s-count) ;; DE
8480: 4c 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 LAY TWEAKER (sti
8490: 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 ll needed?).
84a0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c (if (and (null
84b0: 3f 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 ? tal)(null? reg
84c0: 29 29 0a 09 20 20 28 6c 69 73 74 20 68 65 64 20 )).. (list hed
84d0: 74 61 6c 20 28 61 70 70 65 6e 64 20 72 65 67 20 tal (append reg
84e0: 28 6c 69 73 74 20 68 65 64 29 29 20 72 65 72 75 (list hed)) reru
84f0: 6e 73 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 ns).. (list (ru
8500: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
8510: 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e d tal reg reglen
8520: 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e regfull)...(run
8530: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
8540: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
8550: 72 65 67 66 75 6c 6c 29 0a 09 09 3b 3b 20 4e 42 regfull)...;; NB
8560: 2f 2f 20 48 65 72 65 20 77 65 20 61 72 65 20 62 // Here we are b
8570: 75 69 6c 64 69 6e 67 20 72 65 67 20 61 73 20 77 uilding reg as w
8580: 65 20 72 65 67 69 73 74 65 72 20 74 65 73 74 73 e register tests
8590: 0a 09 09 3b 3b 20 69 66 20 72 65 67 66 75 6c 6c ...;; if regfull
85a0: 20 77 65 20 6d 75 73 74 20 70 6f 70 20 74 68 65 we must pop the
85b0: 20 66 72 6f 6e 74 20 69 74 65 6d 20 6f 66 66 20 front item off
85c0: 72 65 67 0a 09 09 28 69 66 20 72 65 67 66 75 6c reg...(if regful
85d0: 6c 0a 09 09 20 20 20 20 28 61 70 70 65 6e 64 20 l... (append
85e0: 28 63 64 72 20 72 65 67 29 20 28 6c 69 73 74 20 (cdr reg) (list
85f0: 68 65 64 29 29 0a 09 09 20 20 20 20 28 61 70 70 hed))... (app
8600: 65 6e 64 20 72 65 67 20 28 6c 69 73 74 20 68 65 end reg (list he
8610: 64 29 29 29 0a 09 09 72 65 72 75 6e 73 29 29 29 d)))...reruns)))
8620: 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 41 . . ;; A
8630: 74 20 74 68 69 73 20 70 6f 69 6e 74 20 68 65 64 t this point hed
8640: 20 74 65 73 74 20 72 65 67 69 73 74 72 61 74 69 test registrati
8650: 6f 6e 20 6d 75 73 74 20 62 65 20 63 6f 6d 70 6c on must be compl
8660: 65 74 65 64 2e 0a 20 20 20 20 20 3b 3b 0a 20 20 eted.. ;;.
8670: 20 20 20 28 28 65 71 3f 20 28 68 61 73 68 2d 74 ((eq? (hash-t
8680: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
8690: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
86a0: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
86b0: 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 l-name test-name
86c0: 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 0a item-path) #f).
86d0: 09 20 20 20 27 73 74 61 72 74 29 0a 20 20 20 20 . 'start).
86e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
86f0: 6e 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 6f nfo 0 "Waiting o
8700: 6e 20 74 65 73 74 20 72 65 67 69 73 74 72 61 74 n test registrat
8710: 69 6f 6e 28 73 29 3a 20 22 0a 09 09 09 28 73 74 ion(s): "....(st
8720: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
8730: 20 0a 09 09 09 20 28 66 69 6c 74 65 72 20 28 6c .... (filter (l
8740: 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 20 ambda (x).....
8750: 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c (eq? (hash-tabl
8760: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
8770: 73 74 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 st-registry x #f
8780: 29 20 27 73 74 61 72 74 29 29 0a 09 09 09 09 20 ) 'start)).....
8790: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
87a0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 29 29 test-registry))
87b0: 0a 09 09 09 20 22 2c 20 22 29 29 0a 20 20 20 20 .... ", ")).
87c0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
87d0: 20 30 2e 30 35 31 29 0a 20 20 20 20 20 20 28 6c 0.051). (l
87e0: 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 ist hed tal reg
87f0: 72 65 72 75 6e 73 29 29 0a 20 20 20 20 20 0a 20 reruns)). .
8800: 20 20 20 20 3b 3b 20 49 66 20 6e 6f 20 72 65 73 ;; If no res
8810: 6f 75 72 63 65 73 20 61 72 65 20 61 76 61 69 6c ources are avail
8820: 61 62 6c 65 20 6a 75 73 74 20 6b 69 6c 6c 20 74 able just kill t
8830: 69 6d 65 20 61 6e 64 20 6c 6f 6f 70 20 61 67 61 ime and loop aga
8840: 69 6e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 in. ;;.
8850: 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 ((not have-resou
8860: 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 rces) ;; simply
8870: 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 try again after
8880: 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 waiting a second
8890: 0a 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 . (if (runs
88a0: 3a 6c 6f 77 6e 6f 69 73 65 20 22 6e 6f 20 72 65 :lownoise "no re
88b0: 73 6f 75 72 63 65 73 22 20 36 30 29 0a 09 20 20 sources" 60)..
88c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
88d0: 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 o 1 "no resource
88e0: 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 s to run new tes
88f0: 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 ts, waiting ..."
8900: 29 29 0a 20 20 20 20 20 20 3b 3b 20 48 61 76 65 )). ;; Have
8910: 20 67 6f 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 gone back and f
8920: 6f 72 74 68 20 6f 6e 20 74 68 69 73 20 62 75 74 orth on this but
8930: 20 64 62 20 73 74 61 72 76 61 74 69 6f 6e 20 69 db starvation i
8940: 73 20 61 6e 20 69 73 73 75 65 2e 0a 20 20 20 20 s an issue..
8950: 20 20 3b 3b 20 77 61 69 74 20 6f 6e 65 20 73 65 ;; wait one se
8960: 63 6f 6e 64 20 62 65 66 6f 72 65 20 6c 6f 6f 6b cond before look
8970: 69 6e 67 20 61 67 61 69 6e 20 74 6f 20 72 75 6e ing again to run
8980: 20 6a 6f 62 73 2e 0a 20 20 20 20 20 20 28 74 68 jobs.. (th
8990: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 read-sleep! 1).
89a0: 20 20 20 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ;; could ha
89b0: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
89c0: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
89d0: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
89e0: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
89f0: 0a 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 . (list (ca
8a00: 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 r newtal)(cdr ne
8a10: 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 wtal) reg reruns
8a20: 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b )). . ;;
8a30: 20 54 68 69 73 20 69 73 20 74 68 65 20 66 69 6e This is the fin
8a40: 61 6c 20 73 74 61 67 65 2c 20 65 76 65 72 79 74 al stage, everyt
8a50: 68 69 6e 67 20 69 73 20 69 6e 20 70 6c 61 63 65 hing is in place
8a60: 20 73 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 so launch the t
8a70: 65 73 74 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 est. ;;.
8a80: 20 28 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f ((and have-reso
8a90: 75 72 63 65 73 0a 09 20 20 20 28 6f 72 20 28 6e urces.. (or (n
8aa0: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
8ab0: 2d 6d 65 74 29 0a 09 20 20 20 20 20 20 20 28 61 -met).. (a
8ac0: 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 nd (eq? testmode
8ad0: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 20 20 'toplevel)...
8ae0: 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d (null? non-com
8af0: 70 6c 65 74 65 64 29 29 29 29 0a 20 20 20 20 20 pleted)))).
8b00: 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ;; (hash-table-
8b10: 64 65 6c 65 74 65 21 20 2a 6d 61 78 2d 74 72 69 delete! *max-tri
8b20: 65 73 2d 68 61 73 68 2a 20 28 64 62 3a 74 65 73 es-hash* (db:tes
8b30: 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 t-make-full-name
8b40: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
8b50: 70 61 74 68 29 29 0a 20 20 20 20 20 20 3b 3b 20 path)). ;;
8b60: 77 65 20 61 72 65 20 67 6f 69 6e 67 20 74 6f 20 we are going to
8b70: 72 65 73 65 74 20 61 6c 6c 20 74 68 65 20 63 6f reset all the co
8b80: 75 6e 74 65 72 73 20 66 6f 72 20 74 65 73 74 20 unters for test
8b90: 72 65 74 72 69 65 73 20 62 79 20 73 65 74 74 69 retries by setti
8ba0: 6e 67 20 61 20 6e 65 77 20 68 61 73 68 20 74 61 ng a new hash ta
8bb0: 62 6c 65 0a 20 20 20 20 20 20 3b 3b 20 74 68 69 ble. ;; thi
8bc0: 73 20 6d 65 61 6e 73 20 74 68 65 79 20 77 69 6c s means they wil
8bd0: 6c 20 69 6e 63 72 65 6d 65 6e 74 20 6f 6e 6c 79 l increment only
8be0: 20 77 68 65 6e 20 6e 6f 74 68 69 6e 67 20 63 61 when nothing ca
8bf0: 6e 20 62 65 20 72 75 6e 0a 20 20 20 20 20 20 28 n be run. (
8c00: 73 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 73 2d set! *max-tries-
8c10: 68 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 hash* (make-hash
8c20: 2d 74 61 62 6c 65 29 29 0a 20 20 20 20 20 20 3b -table)). ;
8c30: 3b 20 77 65 6c 6c 2c 20 66 69 72 73 74 20 6c 65 ; well, first le
8c40: 74 73 20 73 65 65 20 69 66 20 63 70 75 20 6c 6f ts see if cpu lo
8c50: 61 64 20 74 68 72 6f 74 74 6c 69 6e 67 20 69 73 ad throttling is
8c60: 20 65 6e 61 62 6c 65 64 2e 20 49 66 20 73 6f 20 enabled. If so
8c70: 77 61 69 74 20 61 72 6f 75 6e 64 20 75 6e 74 69 wait around unti
8c80: 6c 20 74 68 65 0a 20 20 20 20 20 20 3b 3b 20 61 l the. ;; a
8c90: 76 65 72 61 67 65 20 63 70 75 20 6c 6f 61 64 20 verage cpu load
8ca0: 69 73 20 75 6e 64 65 72 20 74 68 65 20 74 68 72 is under the thr
8cb0: 65 73 68 6f 6c 64 20 62 65 66 6f 72 65 20 63 6f eshold before co
8cc0: 6e 74 69 6e 75 69 6e 67 0a 20 20 20 20 20 20 28 ntinuing. (
8cd0: 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b if (configf:look
8ce0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
8cf0: 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 6c 6f jobtools" "maxlo
8d00: 61 64 22 29 20 3b 3b 20 6f 6e 6c 79 20 67 61 74 ad") ;; only gat
8d10: 65 20 69 66 20 6d 61 78 6c 6f 61 64 20 69 73 20 e if maxload is
8d20: 73 70 65 63 69 66 69 65 64 0a 09 20 20 28 63 6f specified.. (co
8d30: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
8d40: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
8d50: 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 29 mcpus waitdelay)
8d60: 29 0a 20 20 20 20 20 20 28 72 75 6e 3a 74 65 73 ). (run:tes
8d70: 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 t run-id run-inf
8d80: 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d o keyvals runnam
8d90: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c e test-record fl
8da0: 61 67 73 20 23 66 20 74 65 73 74 2d 72 65 67 69 ags #f test-regi
8db0: 73 74 72 79 20 61 6c 6c 2d 74 65 73 74 73 2d 72 stry all-tests-r
8dc0: 65 67 69 73 74 72 79 29 0a 20 20 20 20 20 20 28 egistry). (
8dd0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8de0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 test-registry (d
8df0: 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c b:test-make-full
8e00: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
8e10: 69 74 65 6d 2d 70 61 74 68 29 20 27 72 75 6e 6e item-path) 'runn
8e20: 69 6e 67 29 0a 20 20 20 20 20 20 28 72 75 6e 73 ing). (runs
8e30: 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d :shrink-can-run-
8e40: 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 more-tests-count
8e50: 29 20 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 ) ;; DELAY TWEA
8e60: 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 KER (still neede
8e70: 64 3f 29 0a 20 20 20 20 20 20 3b 3b 20 28 74 68 d?). ;; (th
8e80: 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f read-sleep! *glo
8e90: 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 20 20 20 20 bal-delta*).
8ea0: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
8eb0: 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 null? tal))(not
8ec0: 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 0a 09 20 (null? reg)))..
8ed0: 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 (list (runs:que
8ee0: 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 ue-next-hed tal
8ef0: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
8f00: 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 ll)...(runs:queu
8f10: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
8f20: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
8f30: 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 l)...(runs:queue
8f40: 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 -next-reg tal re
8f50: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
8f60: 29 0a 09 09 72 65 72 75 6e 73 29 0a 09 20 20 23 )...reruns).. #
8f70: 66 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b f)). . ;
8f80: 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 76 ; must be we hav
8f90: 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 69 e unmet prerequi
8fa0: 73 69 74 65 73 0a 20 20 20 20 20 3b 3b 0a 20 20 sites. ;;.
8fb0: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 (else. (
8fc0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 debug:print 4 "F
8fd0: 41 49 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a 20 AILS: " fails).
8fe0: 20 20 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f ;; If one o
8ff0: 72 20 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 72 r more of the pr
9000: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 ereqs-not-met ar
9010: 65 20 46 41 49 4c 20 74 68 65 6e 20 77 65 20 63 e FAIL then we c
9020: 61 6e 20 69 73 73 75 65 0a 20 20 20 20 20 20 3b an issue. ;
9030: 3b 20 61 20 6d 65 73 73 61 67 65 20 61 6e 64 20 ; a message and
9040: 64 72 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 68 drop hed from th
9050: 65 20 69 74 65 6d 73 20 74 6f 20 62 65 20 70 72 e items to be pr
9060: 6f 63 65 73 73 65 64 2e 0a 20 20 20 20 20 20 3b ocessed.. ;
9070: 3b 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 ; (runs:mixed-li
9080: 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d st-testname-and-
9090: 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 testrec->list-of
90a0: 2d 73 74 72 69 6e 67 73 20 70 72 65 72 65 71 73 -strings prereqs
90b0: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 20 20 20 20 -not-met).
90c0: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e (if (and (not (n
90d0: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
90e0: 2d 6d 65 74 29 29 0a 09 20 20 20 20 20 20 20 28 -met)).. (
90f0: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 runs:lownoise (c
9100: 6f 6e 63 20 22 77 61 69 74 69 6e 67 20 6f 6e 20 onc "waiting on
9110: 74 65 73 74 73 20 22 20 70 72 65 72 65 71 73 2d tests " prereqs-
9120: 6e 6f 74 2d 6d 65 74 20 68 65 64 29 20 36 30 29 not-met hed) 60)
9130: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
9140: 74 2d 69 6e 66 6f 20 31 20 22 77 61 69 74 69 6e t-info 1 "waitin
9150: 67 20 6f 6e 20 74 65 73 74 73 3b 20 22 20 28 73 g on tests; " (s
9160: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
9170: 65 20 0a 09 09 09 09 09 09 20 20 20 20 28 72 75 e ....... (ru
9180: 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 2d 74 65 ns:mixed-list-te
9190: 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 73 74 72 stname-and-testr
91a0: 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 69 ec->list-of-stri
91b0: 6e 67 73 20 0a 09 09 09 09 09 09 20 20 20 20 20 ngs .......
91c0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
91d0: 20 22 2c 20 22 29 29 29 0a 20 20 20 20 20 20 28 ", "))). (
91e0: 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 if (null? fails)
91f0: 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
9200: 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c ;; couldn't run,
9210: 20 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 take a breather
9220: 0a 09 20 20 20 20 28 69 66 20 20 28 72 75 6e 73 .. (if (runs
9230: 3a 6c 6f 77 6e 6f 69 73 65 20 22 57 61 69 74 69 :lownoise "Waiti
9240: 6e 67 20 66 6f 72 20 6d 6f 72 65 20 77 6f 72 6b ng for more work
9250: 20 74 6f 20 64 6f 2e 2e 2e 22 20 36 30 29 0a 09 to do..." 60)..
9260: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
9270: 6e 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 66 nfo 0 "Waiting f
9280: 6f 72 20 6d 6f 72 65 20 77 6f 72 6b 20 74 6f 20 or more work to
9290: 64 6f 2e 2e 2e 22 29 29 0a 09 20 20 20 20 28 74 do...")).. (t
92a0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
92b0: 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 20 . (list (car
92c0: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
92d0: 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 al) reg reruns))
92e0: 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 6f .. ;; the waito
92f0: 6e 20 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f 20 n is FAIL so no
9300: 70 6f 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 20 point in trying
9310: 74 6f 20 72 75 6e 20 68 65 64 20 65 76 65 72 20 to run hed ever
9320: 61 67 61 69 6e 0a 09 20 20 28 69 66 20 28 6f 72 again.. (if (or
9330: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 (not (null? reg
9340: 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 ))(not (null? ta
9350: 6c 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 l))).. (if
9360: 28 76 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 09 (vector? hed)...
9370: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
9380: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 debug:print 1 "W
9390: 41 52 4e 49 4e 47 3a 20 44 72 6f 70 70 69 6e 67 ARNING: Dropping
93a0: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
93b0: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 0a e "/" item-path.
93c0: 09 09 09 09 20 22 20 66 72 6f 6d 20 74 68 65 20 .... " from the
93d0: 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 69 launch list as i
93e0: 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 t has prerequist
93f0: 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c es that are FAIL
9400: 22 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 ")... (let ((
9410: 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 test-id (rmt:get
9420: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
9430: 68 65 64 20 22 22 29 29 29 0a 09 09 20 20 20 20 hed "")))...
9440: 20 20 28 69 66 20 74 65 73 74 2d 69 64 20 28 6d (if test-id (m
9450: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
9460: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
9470: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f n-id test-id "NO
9480: 54 5f 53 54 41 52 54 45 44 22 20 22 50 52 45 51 T_STARTED" "PREQ
9490: 5f 46 41 49 4c 22 20 22 46 61 69 6c 65 64 20 74 _FAIL" "Failed t
94a0: 6f 20 72 75 6e 20 64 75 65 20 74 6f 20 66 61 69 o run due to fai
94b0: 6c 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 led prerequisite
94c0: 73 22 29 29 29 0a 09 09 20 20 20 20 28 72 75 6e s")))... (run
94d0: 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e s:shrink-can-run
94e0: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
94f0: 74 29 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 t) ;; DELAY TWEA
9500: 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 KER (still neede
9510: 64 3f 29 0a 09 09 20 20 20 20 3b 3b 20 28 74 68 d?)... ;; (th
9520: 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f read-sleep! *glo
9530: 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 20 bal-delta*)...
9540: 20 20 3b 3b 20 54 68 69 73 20 6e 65 78 74 20 69 ;; This next i
9550: 73 20 66 6f 72 20 74 68 65 20 69 74 65 6d 73 0a s for the items.
9560: 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 .. (mt:test-s
9570: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
9580: 62 79 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d by-testname run-
9590: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
95a0: 6d 2d 70 61 74 68 20 22 4e 4f 54 5f 53 54 41 52 m-path "NOT_STAR
95b0: 54 45 44 22 20 22 42 4c 4f 43 4b 45 44 22 20 23 TED" "BLOCKED" #
95c0: 66 29 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 f)... (hash-t
95d0: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
95e0: 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 egistry (db:test
95f0: 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
9600: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
9610: 61 74 68 29 20 27 72 65 6d 6f 76 65 64 29 0a 09 ath) 'removed)..
9620: 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 . (list (runs
9630: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
9640: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
9650: 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 72 75 egfull).... (ru
9660: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 ns:queue-next-ta
9670: 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e l tal reg reglen
9680: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 regfull).... (
9690: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
96a0: 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c reg tal reg regl
96b0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 en regfull)....
96c0: 20 72 65 72 75 6e 73 20 3b 3b 20 57 41 53 3a 20 reruns ;; WAS:
96d0: 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 (cons hed reruns
96e0: 29 20 3b 3b 20 62 75 74 20 74 68 61 74 20 6d 61 ) ;; but that ma
96f0: 6b 65 73 20 6e 6f 20 73 65 6e 73 65 3f 0a 09 09 kes no sense?...
9700: 09 20 20 29 29 0a 09 09 20 20 28 6c 65 74 20 28 . ))... (let (
9710: 28 6e 74 68 2d 74 72 79 20 28 68 61 73 68 2d 74 (nth-try (hash-t
9720: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
9730: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 test-registry h
9740: 65 64 20 30 29 29 29 0a 09 09 20 20 20 20 28 63 ed 0)))... (c
9750: 6f 6e 64 0a 09 09 20 20 20 20 20 28 28 6d 65 6d ond... ((mem
9760: 62 65 72 20 22 52 55 4e 4e 49 4e 47 22 20 28 6d ber "RUNNING" (m
9770: 61 70 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 ap db:test-get-s
9780: 74 61 74 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 tate prereqs-not
9790: 2d 6d 65 74 29 29 0a 09 09 20 20 20 20 20 20 28 -met))... (
97a0: 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 if (runs:lownois
97b0: 65 20 28 63 6f 6e 63 20 22 70 6f 73 73 69 62 6c e (conc "possibl
97c0: 65 20 52 55 4e 4e 49 4e 47 20 70 72 65 72 65 71 e RUNNING prereq
97d0: 75 69 73 74 65 73 20 22 20 68 65 64 29 20 36 30 uistes " hed) 60
97e0: 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ).... (debug:pr
97f0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
9800: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
9810: 20 70 6f 73 73 69 62 6c 65 20 52 55 4e 4e 49 4e possible RUNNIN
9820: 47 20 70 72 65 72 65 71 75 69 73 69 74 65 73 2c G prerequisites,
9830: 20 64 6f 6e 27 74 20 67 69 76 65 20 75 70 20 6f don't give up o
9840: 6e 20 69 74 20 79 65 74 2e 22 29 29 0a 09 09 20 n it yet."))...
9850: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
9860: 65 70 21 20 34 29 0a 09 09 20 20 20 20 20 20 28 ep! 4)... (
9870: 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 list (runs:queue
9880: 2d 6e 65 78 74 2d 68 65 64 20 6e 65 77 74 61 6c -next-hed newtal
9890: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
98a0: 75 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e ull).... (run
98b0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
98c0: 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c newtal reg regl
98d0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 en regfull)....
98e0: 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e (runs:queue-n
98f0: 65 78 74 2d 72 65 67 20 6e 65 77 74 61 6c 20 72 ext-reg newtal r
9900: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
9910: 6c 29 0a 09 09 09 20 20 20 20 72 65 72 75 6e 73 l).... reruns
9920: 29 29 0a 09 09 20 20 20 20 20 28 28 6f 72 20 28 ))... ((or (
9930: 6e 6f 74 20 6e 74 68 2d 74 72 79 29 0a 09 09 09 not nth-try)....
9940: 20 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 (and (number?
9950: 6e 74 68 2d 74 72 79 29 0a 09 09 09 20 20 20 20 nth-try)....
9960: 20 20 20 28 3c 20 6e 74 68 2d 74 72 79 20 31 30 (< nth-try 10
9970: 29 29 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 )))... (has
9980: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
9990: 74 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 28 t-registry hed (
99a0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 74 68 2d if (number? nth-
99b0: 74 72 79 29 0a 09 09 09 09 09 09 09 20 20 20 20 try)........
99c0: 20 28 2b 20 6e 74 68 2d 74 72 79 20 31 29 0a 09 (+ nth-try 1)..
99d0: 09 09 09 09 09 09 20 20 20 20 20 30 29 29 0a 09 ...... 0))..
99e0: 09 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 . (if (runs
99f0: 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 :lownoise (conc
9a00: 22 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 74 65 "not removing te
9a10: 73 74 20 22 20 68 65 64 29 20 36 30 29 0a 09 09 st " hed) 60)...
9a20: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
9a30: 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 1 "WARNING: not
9a40: 72 65 6d 6f 76 69 6e 67 20 74 65 73 74 20 22 20 removing test "
9a50: 68 65 64 20 22 20 66 72 6f 6d 20 71 75 65 75 65 hed " from queue
9a60: 20 61 6c 74 68 6f 75 67 68 20 69 74 20 6d 61 79 although it may
9a70: 20 6e 6f 74 20 62 65 20 72 75 6e 6e 61 62 6c 65 not be runnable
9a80: 20 64 75 65 20 74 6f 20 46 41 49 4c 45 44 20 70 due to FAILED p
9a90: 72 65 72 65 71 75 69 73 69 74 65 73 22 29 29 0a rerequisites")).
9aa0: 09 09 20 20 20 20 20 20 3b 3b 20 6d 61 79 20 6e .. ;; may n
9ab0: 6f 74 20 68 61 76 65 20 70 72 6f 63 65 73 73 65 ot have processe
9ac0: 64 20 63 6f 72 72 65 63 74 6c 79 2e 20 43 6f 75 d correctly. Cou
9ad0: 6c 64 20 62 65 20 61 20 72 61 63 65 20 63 6f 6e ld be a race con
9ae0: 64 69 74 69 6f 6e 20 69 6e 20 79 6f 75 72 20 74 dition in your t
9af0: 65 73 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 est implementati
9b00: 6f 6e 3f 20 44 72 6f 70 70 69 6e 67 20 74 65 73 on? Dropping tes
9b10: 74 20 22 20 68 65 64 29 20 3b 3b 20 20 22 20 61 t " hed) ;; " a
9b20: 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 s it has prerequ
9b30: 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 istes that are F
9b40: 41 49 4c 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 AIL. (NOTE: hed
9b50: 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 is not a vector)
9b60: 22 29 0a 09 09 20 20 20 20 20 20 28 72 75 6e 73 ")... (runs
9b70: 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d :shrink-can-run-
9b80: 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 more-tests-count
9b90: 29 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b ) ;; DELAY TWEAK
9ba0: 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 ER (still needed
9bb0: 3f 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 6c ?)... ;; (l
9bc0: 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 ist hed tal reg
9bd0: 72 65 72 75 6e 73 29 0a 09 09 20 20 20 20 20 20 reruns)...
9be0: 3b 3b 20 28 6c 69 73 74 20 28 63 61 72 20 6e 65 ;; (list (car ne
9bf0: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
9c00: 29 20 72 65 67 20 72 65 72 75 6e 73 29 0a 09 09 ) reg reruns)...
9c10: 20 20 20 20 20 20 3b 3b 20 28 68 61 73 68 2d 74 ;; (hash-t
9c20: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
9c30: 65 67 69 73 74 72 79 20 68 65 64 20 27 72 65 6d egistry hed 'rem
9c40: 6f 76 65 64 29 0a 09 09 20 20 20 20 20 20 28 6c oved)... (l
9c50: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
9c60: 6e 65 78 74 2d 68 65 64 20 6e 65 77 74 61 6c 20 next-hed newtal
9c70: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
9c80: 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 ll).... (runs
9c90: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
9ca0: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
9cb0: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
9cc0: 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 (runs:queue-ne
9cd0: 78 74 2d 72 65 67 20 6e 65 77 74 61 6c 20 72 65 xt-reg newtal re
9ce0: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
9cf0: 29 0a 09 09 09 20 20 20 20 72 65 72 75 6e 73 29 ).... reruns)
9d00: 29 0a 09 09 20 20 20 20 20 28 28 73 79 6d 62 6f )... ((symbo
9d10: 6c 3f 20 6e 74 68 2d 74 72 79 29 0a 09 09 20 20 l? nth-try)...
9d20: 20 20 20 20 28 69 66 20 28 65 71 3f 20 6e 74 68 (if (eq? nth
9d30: 2d 74 72 79 20 27 72 65 6d 6f 76 65 64 29 20 3b -try 'removed) ;
9d40: 3b 20 72 65 6d 6f 76 65 64 20 69 73 20 72 65 6d ; removed is rem
9d50: 6f 76 65 64 20 2d 20 64 72 6f 70 20 69 74 20 4e oved - drop it N
9d60: 4f 57 0a 09 09 09 20 20 28 69 66 20 28 6e 75 6c OW.... (if (nul
9d70: 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 20 20 l? tal)....
9d80: 20 23 66 20 3b 3b 20 79 65 73 2c 20 72 65 61 6c #f ;; yes, real
9d90: 6c 79 0a 09 09 09 20 20 20 20 20 20 28 6c 69 73 ly.... (lis
9da0: 74 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 t (car tal)(cdr
9db0: 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 tal) reg reruns)
9dc0: 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ).... (begin...
9dd0: 09 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c . (if (runs:l
9de0: 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 46 ownoise (conc "F
9df0: 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 73 69 AILED prerequisi
9e00: 74 65 73 20 6f 72 20 6f 74 68 65 72 20 69 73 73 tes or other iss
9e10: 75 65 22 20 68 65 64 29 20 36 30 29 0a 09 09 09 ue" hed) 60)....
9e20: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
9e30: 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 "WARNING: test "
9e40: 20 68 65 64 20 22 20 68 61 73 20 46 41 49 4c 45 hed " has FAILE
9e50: 44 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 D prerequisites
9e60: 6f 72 20 6f 74 68 65 72 20 69 73 73 75 65 2e 20 or other issue.
9e70: 49 6e 74 65 72 6e 61 6c 20 73 74 61 74 65 20 22 Internal state "
9e80: 20 6e 74 68 2d 74 72 79 20 22 20 77 69 6c 6c 20 nth-try " will
9e90: 62 65 20 6f 76 65 72 72 69 64 64 65 6e 20 61 6e be overridden an
9ea0: 64 20 77 65 27 6c 6c 20 72 65 74 72 79 2e 22 29 d we'll retry.")
9eb0: 29 0a 09 09 09 20 20 20 20 28 6d 74 3a 74 65 73 ).... (mt:tes
9ec0: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
9ed0: 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d 65 20 72 us-by-testname r
9ee0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
9ef0: 69 74 65 6d 2d 70 61 74 68 20 22 4e 4f 54 5f 53 item-path "NOT_S
9f00: 54 41 52 54 45 44 22 20 22 4b 45 45 50 5f 54 52 TARTED" "KEEP_TR
9f10: 59 49 4e 47 22 20 23 66 29 0a 09 09 09 20 20 20 YING" #f)....
9f20: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
9f30: 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
9f40: 68 65 64 20 30 29 0a 09 09 09 20 20 20 20 28 6c hed 0).... (l
9f50: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
9f60: 6e 65 78 74 2d 68 65 64 20 6e 65 77 74 61 6c 20 next-hed newtal
9f70: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
9f80: 6c 6c 29 0a 09 09 09 09 20 20 28 72 75 6e 73 3a ll)..... (runs:
9f90: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 6e queue-next-tal n
9fa0: 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e ewtal reg reglen
9fb0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 09 20 20 regfull).....
9fc0: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
9fd0: 2d 72 65 67 20 6e 65 77 74 61 6c 20 72 65 67 20 -reg newtal reg
9fe0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
9ff0: 09 09 09 09 20 20 72 65 72 75 6e 73 29 29 29 29 .... reruns))))
a000: 0a 09 09 20 20 20 20 20 28 65 6c 73 65 0a 09 09 ... (else...
a010: 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a (if (runs:
a020: 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 lownoise (conc "
a030: 46 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 74 FAILED prerequit
a040: 65 73 74 73 20 61 6e 64 20 77 65 20 74 72 69 65 ests and we trie
a050: 64 22 20 68 65 64 29 20 36 30 29 0a 09 09 09 20 d" hed) 60)....
a060: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a070: 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 "WARNING: test "
a080: 20 68 65 64 20 22 20 68 61 73 20 46 41 49 4c 45 hed " has FAILE
a090: 44 20 70 72 65 72 65 71 75 69 74 65 73 74 73 20 D prerequitests
a0a0: 61 6e 64 20 77 65 27 76 65 20 74 72 69 65 64 20 and we've tried
a0b0: 61 74 20 6c 65 61 73 74 20 31 30 20 74 69 6d 65 at least 10 time
a0c0: 73 20 74 6f 20 72 75 6e 20 69 74 2e 20 47 69 76 s to run it. Giv
a0d0: 69 6e 67 20 75 70 20 6e 6f 77 2e 22 29 29 0a 09 ing up now."))..
a0e0: 09 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 . ;; (debug
a0f0: 3a 70 72 69 6e 74 20 30 20 22 20 20 20 20 20 20 :print 0 "
a100: 20 20 20 70 72 65 72 65 71 73 3a 20 22 20 70 72 prereqs: " pr
a110: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 ereqs-not-met)..
a120: 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
a130: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
a140: 69 73 74 72 79 20 68 65 64 20 27 72 65 6d 6f 76 istry hed 'remov
a150: 65 64 29 0a 09 09 20 20 20 20 20 20 28 6d 74 3a ed)... (mt:
a160: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
a170: 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d tatus-by-testnam
a180: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 e run-id test-na
a190: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 22 4e 4f me item-path "NO
a1a0: 54 5f 53 54 41 52 54 45 44 22 20 22 54 45 4e 5f T_STARTED" "TEN_
a1b0: 53 54 52 49 4b 45 53 22 20 23 66 29 0a 09 09 20 STRIKES" #f)...
a1c0: 20 20 20 20 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 (rmt:roll-u
a1d0: 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e p-pass-fail-coun
a1e0: 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ts run-id test-n
a1f0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 22 46 ame item-path "F
a200: 41 49 4c 22 29 20 3b 3b 20 74 72 65 61 74 20 61 AIL") ;; treat a
a210: 73 20 46 41 49 4c 0a 09 09 20 20 20 20 20 20 28 s FAIL... (
a220: 6c 69 73 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 list (if (null?
a230: 74 61 6c 29 28 63 61 72 20 6e 65 77 74 61 6c 29 tal)(car newtal)
a240: 28 63 61 72 20 74 61 6c 29 29 0a 09 09 09 20 20 (car tal))....
a250: 20 20 74 61 6c 0a 09 09 09 20 20 20 20 72 65 67 tal.... reg
a260: 0a 09 09 09 20 20 20 20 72 65 72 75 6e 73 29 29 .... reruns))
a270: 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 63 61 ))).. ;; ca
a280: 6e 27 74 20 64 72 6f 70 20 74 68 69 73 20 2d 20 n't drop this -
a290: 6d 61 79 62 65 20 72 75 6e 6e 69 6e 67 3f 20 4a maybe running? J
a2a0: 75 73 74 20 6b 65 65 70 20 74 72 79 69 6e 67 0a ust keep trying.
a2b0: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 . (let ((ru
a2c0: 6e 61 62 6c 65 2d 74 65 73 74 73 20 28 72 75 6e nable-tests (run
a2d0: 73 3a 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 20 s:runable-tests
a2e0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
a2f0: 29 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 ))...(if (null?
a300: 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 29 0a 09 runable-tests)..
a310: 09 20 20 20 20 23 66 20 20 20 3b 3b 20 49 20 74 . #f ;; I t
a320: 68 69 6e 6b 20 77 65 20 61 72 65 20 74 72 75 6c hink we are trul
a330: 79 20 64 6f 6e 65 20 68 65 72 65 0a 09 09 20 20 y done here...
a340: 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 (list (runs:qu
a350: 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e 65 77 eue-next-hed new
a360: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
a370: 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 28 egfull).... (
a380: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
a390: 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 20 72 tal newtal reg r
a3a0: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
a3b0: 09 09 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 .. (runs:queu
a3c0: 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 74 61 e-next-reg newta
a3d0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
a3e0: 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 72 65 72 full).... rer
a3f0: 75 6e 73 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b uns)))))))))..;;
a400: 20 73 63 61 6e 20 61 20 6c 69 73 74 20 6f 66 20 scan a list of
a410: 74 65 73 74 73 20 6c 6f 6f 6b 69 6e 67 20 74 6f tests looking to
a420: 20 73 65 65 20 69 66 20 61 6e 79 20 61 72 65 20 see if any are
a430: 70 6f 74 65 6e 74 69 61 6c 6c 79 20 72 75 6e 6e potentially runn
a440: 61 62 6c 65 0a 28 64 65 66 69 6e 65 20 28 72 75 able.(define (ru
a450: 6e 73 3a 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 ns:runable-tests
a460: 20 74 65 73 74 73 29 0a 20 20 28 66 69 6c 74 65 tests). (filte
a470: 72 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 r (lambda (t)..
a480: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 (if (not (vec
a490: 74 6f 72 3f 20 74 29 29 0a 09 09 74 0a 09 09 28 tor? t))...t...(
a4a0: 6c 65 74 20 28 28 73 74 61 74 65 20 20 28 64 62 let ((state (db
a4b0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
a4c0: 74 29 29 0a 09 09 20 20 20 20 20 20 28 73 74 61 t))... (sta
a4d0: 74 75 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 tus (db:test-get
a4e0: 2d 73 74 61 74 75 73 20 74 29 29 29 0a 09 09 20 -status t)))...
a4f0: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
a500: 73 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a 09 09 symbol state)...
a510: 20 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 29 ((COMPLETED)
a520: 20 23 66 29 0a 09 09 20 20 20 20 28 28 4e 4f 54 #f)... ((NOT
a530: 5f 53 54 41 52 54 45 44 29 0a 09 09 20 20 20 20 _STARTED)...
a540: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 73 74 61 (if (member sta
a550: 74 75 73 20 27 28 22 54 45 4e 5f 53 54 52 49 4b tus '("TEN_STRIK
a560: 45 53 22 20 22 42 4c 4f 43 4b 45 44 22 20 22 50 ES" "BLOCKED" "P
a570: 52 45 51 5f 46 41 49 4c 22 20 22 5a 45 52 4f 5f REQ_FAIL" "ZERO_
a580: 49 54 45 4d 53 22 20 22 50 52 45 51 5f 44 49 53 ITEMS" "PREQ_DIS
a590: 43 41 52 44 45 44 22 20 22 54 49 4d 45 44 5f 4f CARDED" "TIMED_O
a5a0: 55 54 22 20 29 29 0a 09 09 09 20 23 66 0a 09 09 UT" )).... #f...
a5b0: 09 20 74 29 29 0a 09 09 20 20 20 20 28 28 44 45 . t))... ((DE
a5c0: 4c 45 54 45 44 29 20 23 66 29 0a 09 09 20 20 20 LETED) #f)...
a5d0: 20 28 65 6c 73 65 20 74 29 29 29 29 29 0a 09 20 (else t)))))..
a5e0: 20 74 65 73 74 73 29 29 0a 0a 3b 3b 20 65 76 65 tests))..;; eve
a5f0: 72 79 20 74 69 6d 65 20 74 68 6f 75 67 68 20 74 ry time though t
a600: 68 65 20 6c 6f 6f 70 20 69 6e 63 72 65 6d 65 6e he loop incremen
a610: 74 20 74 68 65 20 74 65 73 74 2f 69 74 65 6d 70 t the test/itemp
a620: 61 74 74 20 76 61 6c 2e 0a 3b 3b 20 77 68 65 6e att val..;; when
a630: 20 74 68 65 20 6d 69 6e 20 69 73 20 3e 20 6d 61 the min is > ma
a640: 78 2d 61 6c 6c 6f 77 65 64 20 61 6e 64 20 6e 6f x-allowed and no
a650: 6e 65 20 72 75 6e 6e 69 6e 67 20 74 68 65 6e 20 ne running then
a660: 66 6f 72 63 65 20 65 78 69 74 0a 3b 3b 0a 28 64 force exit.;;.(d
a670: 65 66 69 6e 65 20 2a 6d 61 78 2d 74 72 69 65 73 efine *max-tries
a680: 2d 68 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 -hash* (make-has
a690: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 74 65 h-table))..;; te
a6a0: 73 74 2d 72 65 63 6f 72 64 73 20 69 73 20 61 20 st-records is a
a6b0: 68 61 73 68 20 74 61 62 6c 65 20 74 65 73 74 6e hash table testn
a6c0: 61 6d 65 3a 69 74 65 6d 5f 70 61 74 68 20 3d 3e ame:item_path =>
a6d0: 20 76 65 63 74 6f 72 20 3c 20 74 65 73 74 6e 61 vector < testna
a6e0: 6d 65 20 74 65 73 74 63 6f 6e 66 69 67 20 77 61 me testconfig wa
a6f0: 69 74 6f 6e 73 20 70 72 69 6f 72 69 74 79 20 69 itons priority i
a700: 74 65 6d 73 2d 69 6e 66 6f 20 2e 2e 2e 20 3e 0a tems-info ... >.
a710: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 (define (runs:ru
a720: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
a730: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
a740: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
a750: 73 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 s flags test-pat
a760: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test
a770: 73 20 72 65 67 6c 65 6e 2d 69 6e 20 61 6c 6c 2d s reglen-in all-
a780: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a tests-registry).
a790: 20 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 ;; At this poi
a7a0: 6e 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 nt the list of p
a7b0: 61 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 arent tests is e
a7c0: 78 70 61 6e 64 65 64 20 0a 20 20 3b 3b 20 4e 42 xpanded . ;; NB
a7d0: 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 // Should expand
a7e0: 20 69 74 65 6d 73 20 68 65 72 65 20 61 6e 64 20 items here and
a7f0: 74 68 65 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f then insert into
a800: 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 2e 0a the run queue..
a810: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 (debug:print 5
a820: 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 "test-records:
a830: 22 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 " test-records "
a840: 2c 20 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 , flags: " (hash
a850: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c -table->alist fl
a860: 61 67 73 29 29 0a 0a 20 20 3b 3b 20 44 6f 20 6d ags)).. ;; Do m
a870: 61 72 6b 2d 61 6e 64 2d 66 69 6e 64 20 63 6c 65 ark-and-find cle
a880: 61 6e 20 75 70 20 6f 66 20 64 62 20 62 65 66 6f an up of db befo
a890: 72 65 20 73 74 61 72 74 69 6e 67 20 72 75 6e 69 re starting runi
a8a0: 6e 67 20 6f 66 20 71 75 75 65 0a 20 20 3b 3b 0a ng of quue. ;;.
a8b0: 20 20 3b 3b 20 28 72 6d 74 3a 66 69 6e 64 2d 61 ;; (rmt:find-a
a8c0: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
a8d0: 74 65 29 0a 0a 20 20 28 6c 65 74 20 28 28 72 75 te).. (let ((ru
a8e0: 6e 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 20 n-info
a8f0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e (rmt:get-run
a900: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 29 0a 09 -info run-id))..
a910: 28 74 65 73 74 73 2d 69 6e 66 6f 20 20 20 20 20 (tests-info
a920: 20 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d 74 (mt:get-t
a930: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e ests-for-run run
a940: 2d 69 64 20 23 66 20 27 28 29 20 27 28 29 29 29 -id #f '() '()))
a950: 20 3b 3b 20 20 71 72 79 76 61 6c 73 3a 20 22 69 ;; qryvals: "i
a960: 64 2c 74 65 73 74 6e 61 6d 65 2c 69 74 65 6d 5f d,testname,item_
a970: 70 61 74 68 22 29 29 0a 09 28 73 6f 72 74 65 64 path"))..(sorted
a980: 2d 74 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 -test-names
a990: 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 (tests:sort-by-p
a9a0: 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 riority-and-wait
a9b0: 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 on test-records)
a9c0: 29 0a 09 28 74 65 73 74 2d 72 65 67 69 73 74 72 )..(test-registr
a9d0: 79 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d y (make-
a9e0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 72 hash-table))..(r
a9f0: 65 67 69 73 74 72 79 2d 6d 75 74 65 78 20 20 20 egistry-mutex
aa00: 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 (make-mutex
aa10: 29 29 0a 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 ))..(num-retries
aa20: 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 0)..(
aa30: 6d 61 78 2d 72 65 74 72 69 65 73 20 20 20 20 20 max-retries
aa40: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
aa50: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
aa60: 20 22 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 "setup" "maxret
aa70: 72 69 65 73 22 29 29 0a 09 28 6d 61 78 2d 63 6f ries"))..(max-co
aa80: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 ncurrent-jobs
aa90: 28 6c 65 74 20 28 28 6d 63 6a 20 28 63 6f 6e 66 (let ((mcj (conf
aaa0: 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 ig-lookup *confi
aab0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 20 20 gdat* "setup"
aac0: 20 20 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e "max_concurren
aad0: 74 5f 6a 6f 62 73 22 29 29 29 0a 09 09 09 09 20 t_jobs"))).....
aae0: 28 69 66 20 28 61 6e 64 20 6d 63 6a 20 28 73 74 (if (and mcj (st
aaf0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a ring->number mcj
ab00: 29 29 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 ))..... (str
ab10: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 ing->number mcj)
ab20: 0a 09 09 09 09 20 20 20 20 20 31 29 29 29 20 3b ..... 1))) ;
ab30: 3b 20 6c 65 6e 67 74 68 20 6f 66 20 74 68 65 20 ; length of the
ab40: 72 65 67 69 73 74 65 72 20 71 75 65 75 65 20 61 register queue a
ab50: 68 65 61 64 0a 09 28 72 65 67 6c 65 6e 20 20 20 head..(reglen
ab60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
ab70: 20 28 6e 75 6d 62 65 72 3f 20 72 65 67 6c 65 6e (number? reglen
ab80: 2d 69 6e 29 20 72 65 67 6c 65 6e 2d 69 6e 20 31 -in) reglen-in 1
ab90: 29 29 0a 09 28 6c 61 73 74 2d 74 69 6d 65 2d 69 ))..(last-time-i
aba0: 6e 63 6f 6d 70 6c 65 74 65 20 20 28 2d 20 28 63 ncomplete (- (c
abb0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
abc0: 39 30 30 29 29 20 3b 3b 20 66 6f 72 63 65 20 61 900)) ;; force a
abd0: 74 20 6c 65 61 73 74 20 6f 6e 65 20 63 6c 65 61 t least one clea
abe0: 6e 20 75 70 20 63 79 63 6c 65 0a 09 28 6c 61 73 n up cycle..(las
abf0: 74 2d 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e t-time-some-runn
ac00: 69 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ing (current-sec
ac10: 6f 6e 64 73 29 29 0a 09 28 74 64 62 64 61 74 20 onds))..(tdbdat
ac20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ac30: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 tasks:open-db)))
ac40: 0a 0a 20 20 20 20 3b 3b 20 49 6e 69 74 69 61 6c .. ;; Initial
ac50: 69 7a 65 20 74 68 65 20 74 65 73 74 2d 72 65 67 ize the test-reg
ac60: 69 73 74 65 72 79 20 68 61 73 68 20 77 69 74 68 istery hash with
ac70: 20 74 65 73 74 73 20 74 68 61 74 20 61 6c 72 65 tests that alre
ac80: 61 64 79 20 68 61 76 65 20 61 20 72 65 63 6f 72 ady have a recor
ac90: 64 0a 20 20 20 20 3b 3b 20 63 6f 6e 76 65 72 74 d. ;; convert
aca0: 20 73 74 61 74 65 20 74 6f 20 73 79 6d 62 6f 6c state to symbol
acb0: 20 61 6e 64 20 75 73 65 20 74 68 61 74 20 61 73 and use that as
acc0: 20 74 68 65 20 68 61 73 68 20 76 61 6c 75 65 0a the hash value.
acd0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
ace0: 61 6d 62 64 61 20 28 74 72 65 63 29 0a 09 09 28 ambda (trec)...(
acf0: 6c 65 74 20 28 28 69 64 20 28 64 62 3a 74 65 73 let ((id (db:tes
ad00: 74 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 t-get-id
ad10: 74 72 65 63 29 29 0a 09 09 20 20 20 20 20 20 28 trec))... (
ad20: 74 6e 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d tn (db:test-get-
ad30: 74 65 73 74 6e 61 6d 65 20 20 74 72 65 63 29 29 testname trec))
ad40: 0a 09 09 20 20 20 20 20 20 28 69 70 20 28 64 62 ... (ip (db
ad50: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
ad60: 61 74 68 20 74 72 65 63 29 29 0a 09 09 20 20 20 ath trec))...
ad70: 20 20 20 28 73 74 20 28 64 62 3a 74 65 73 74 2d (st (db:test-
ad80: 67 65 74 2d 73 74 61 74 65 20 20 20 20 20 74 72 get-state tr
ad90: 65 63 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e ec)))... (if (n
ada0: 6f 74 20 28 65 71 75 61 6c 3f 20 73 74 20 22 44 ot (equal? st "D
adb0: 45 4c 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 ELETED"))...
adc0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
add0: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
ade0: 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 (db:test-make-f
adf0: 75 6c 6c 2d 6e 61 6d 65 20 74 6e 20 69 70 29 20 ull-name tn ip)
ae00: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
ae10: 73 74 29 29 29 29 29 0a 09 20 20 20 20 20 20 74 st))))).. t
ae20: 65 73 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 28 ests-info). (
ae30: 73 65 74 21 20 6d 61 78 2d 72 65 74 72 69 65 73 set! max-retries
ae40: 20 28 69 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 (if (and max-re
ae50: 74 72 69 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e tries (string->n
ae60: 75 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 umber max-retrie
ae70: 73 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 s))(string->numb
ae80: 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 20 er max-retries)
ae90: 31 30 30 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 100)).. (let
aea0: 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 loop ((hed
aeb0: 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 (car sorted-t
aec0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 est-names))..
aed0: 20 20 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 (tal
aee0: 20 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 (cdr sorted-tes
aef0: 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 t-names))..
af00: 20 20 28 72 65 67 20 20 20 20 20 20 20 20 20 27 (reg '
af10: 28 29 29 20 3b 3b 20 72 65 67 69 73 74 65 72 65 ()) ;; registere
af20: 64 2c 20 70 75 74 20 74 68 65 73 65 20 61 74 20 d, put these at
af30: 74 68 65 20 68 65 61 64 20 6f 66 20 74 61 6c 20 the head of tal
af40: 0a 09 20 20 20 20 20 20 20 28 72 65 72 75 6e 73 .. (reruns
af50: 20 20 20 20 20 20 27 28 29 29 29 0a 0a 20 20 20 '()))..
af60: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
af70: 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 l? reruns))(debu
af80: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
af90: 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 reruns=" reruns)
afa0: 29 0a 0a 20 20 20 20 20 20 3b 3b 20 48 65 72 65 ).. ;; Here
afb0: 20 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f 6c 64 we mark any old
afc0: 20 64 65 66 75 6e 63 74 20 74 65 73 74 73 20 61 defunct tests a
afd0: 73 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 44 6f s incomplete. Do
afe0: 20 74 68 69 73 20 65 76 65 72 79 20 66 69 66 74 this every fift
aff0: 65 65 6e 20 6d 69 6e 75 74 65 73 0a 20 20 20 20 een minutes.
b000: 20 20 3b 3b 20 6d 6f 76 69 6e 67 20 74 68 69 73 ;; moving this
b010: 20 74 6f 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 to a parallel t
b020: 68 72 65 61 64 20 61 6e 64 20 6a 75 73 74 20 72 hread and just r
b030: 75 6e 20 69 74 20 6f 6e 63 65 2e 0a 20 20 20 20 un it once..
b040: 20 20 3b 3b 0a 20 20 20 20 20 20 28 69 66 20 28 ;;. (if (
b050: 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e > (current-secon
b060: 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d ds)(+ last-time-
b070: 69 6e 63 6f 6d 70 6c 65 74 65 20 39 30 30 29 29 incomplete 900))
b080: 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 . (begi
b090: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 n. (s
b0a0: 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 2d 69 6e et! last-time-in
b0b0: 63 6f 6d 70 6c 65 74 65 20 28 63 75 72 72 65 6e complete (curren
b0c0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 t-seconds)).
b0d0: 20 20 20 20 20 20 20 20 3b 3b 20 28 72 6d 74 3a ;; (rmt:
b0e0: 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e find-and-mark-in
b0f0: 63 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e complete-all-run
b100: 73 29 0a 09 20 20 20 20 29 29 0a 0a 20 20 20 20 s).. ))..
b110: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f 70 ;; (print "Top
b120: 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 of loop, hed="
b130: 68 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c hed ", tal=" tal
b140: 20 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 72 " ,reruns=" rer
b150: 75 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 2a uns). (let*
b160: 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 ((test-record (
b170: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
b180: 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 est-records hed)
b190: 29 0a 09 20 20 20 20 20 28 74 65 73 74 2d 6e 61 ).. (test-na
b1a0: 6d 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 me (tests:test
b1b0: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
b1c0: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 me test-record))
b1d0: 0a 09 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 .. (tconfig
b1e0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
b1f0: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e ueue-get-testcon
b200: 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 fig test-record)
b210: 29 0a 09 20 20 20 20 20 28 6a 6f 62 67 72 6f 75 ).. (jobgrou
b220: 70 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f p (config-loo
b230: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 74 65 73 kup tconfig "tes
b240: 74 5f 6d 65 74 61 22 20 22 6a 6f 62 67 72 6f 75 t_meta" "jobgrou
b250: 70 22 29 29 0a 09 20 20 20 20 20 28 74 65 73 74 p")).. (test
b260: 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d mode (let ((m
b270: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
b280: 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 tconfig "require
b290: 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 ments" "mode")))
b2a0: 0a 09 09 09 20 20 20 20 28 69 66 20 6d 20 28 6d .... (if m (m
b2b0: 61 70 20 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f ap string->symbo
b2c0: 6c 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 l (string-split
b2d0: 6d 29 29 20 27 28 6e 6f 72 6d 61 6c 29 29 29 29 m)) '(normal))))
b2e0: 0a 09 20 20 20 20 20 28 69 74 65 6d 6d 61 70 20 .. (itemmap
b2f0: 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (configf:loo
b300: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 kup tconfig "req
b310: 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d uirements" "item
b320: 6d 61 70 22 29 29 0a 09 20 20 20 20 20 28 77 61 map")).. (wa
b330: 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 itons (tests
b340: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
b350: 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 aitons test-r
b360: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 70 ecord)).. (p
b370: 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 riority (test
b380: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
b390: 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d priority test-
b3a0: 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 record)).. (
b3b0: 69 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 itemdat (tes
b3c0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
b3d0: 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 -itemdat test
b3e0: 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 -record)) ;; ite
b3f0: 6d 64 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 mdat can be a st
b400: 72 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 ring, list or #f
b410: 0a 09 20 20 20 20 20 28 69 74 65 6d 73 20 20 20 .. (items
b420: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
b430: 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 20 20 ueue-get-items
b440: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
b450: 29 0a 09 20 20 20 20 20 28 69 74 65 6d 2d 70 61 ).. (item-pa
b460: 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d th (item-list-
b470: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
b480: 09 20 20 20 20 20 28 74 66 75 6c 6c 6e 61 6d 65 . (tfullname
b490: 20 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 (db:test-make
b4a0: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
b4b0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
b4c0: 0a 09 20 20 20 20 20 28 6e 65 77 74 61 6c 20 20 .. (newtal
b4d0: 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 (append tal
b4e0: 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 20 20 (list hed)))..
b4f0: 20 20 20 28 72 65 67 66 75 6c 6c 20 20 20 20 20 (regfull
b500: 28 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 67 29 (>= (length reg)
b510: 20 72 65 67 6c 65 6e 29 29 0a 09 20 20 20 20 20 reglen))..
b520: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 72 6d (num-running (rm
b530: 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 t:get-count-test
b540: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 s-running-for-ru
b550: 6e 2d 69 64 20 72 75 6e 2d 69 64 29 29 29 0a 0a n-id run-id)))..
b560: 09 3b 3b 20 65 76 65 72 79 20 63 6f 75 70 6c 65 .;; every couple
b570: 20 6d 69 6e 75 74 65 73 20 76 65 72 69 66 79 20 minutes verify
b580: 74 68 65 20 73 65 72 76 65 72 20 69 73 20 74 68 the server is th
b590: 65 72 65 20 66 6f 72 20 74 68 69 73 20 72 75 6e ere for this run
b5a0: 0a 09 28 69 66 20 28 61 6e 64 20 28 63 6f 6d 6d ..(if (and (comm
b5b0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
b5c0: 6e 74 20 36 30 20 22 74 72 79 20 73 74 61 72 74 nt 60 "try start
b5d0: 20 73 65 72 76 65 72 22 20 20 72 75 6e 2d 69 64 server" run-id
b5e0: 29 0a 09 09 20 28 74 61 73 6b 73 3a 6e 65 65 64 )... (tasks:need
b5f0: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 29 -server run-id))
b600: 0a 09 20 20 20 20 28 74 61 73 6b 73 3a 73 74 61 .. (tasks:sta
b610: 72 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d rt-and-wait-for-
b620: 73 65 72 76 65 72 20 74 64 62 64 61 74 20 72 75 server tdbdat ru
b630: 6e 2d 69 64 20 31 30 29 29 20 3b 3b 20 4e 4f 54 n-id 10)) ;; NOT
b640: 45 3a 20 64 65 6c 61 79 20 61 6e 64 20 77 61 69 E: delay and wai
b650: 74 20 69 73 20 64 6f 6e 65 20 75 6e 64 65 72 20 t is done under
b660: 74 68 65 20 68 6f 6f 64 0a 09 0a 09 28 69 66 20 the hood....(if
b670: 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 (> num-running 0
b680: 29 0a 09 20 20 28 73 65 74 21 20 6c 61 73 74 2d ).. (set! last-
b690: 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e time-some-runnin
b6a0: 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e g (current-secon
b6b0: 64 73 29 29 29 0a 0a 20 20 20 20 20 20 28 69 66 ds))).. (if
b6c0: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
b6d0: 6f 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d onds)(+ last-tim
b6e0: 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 e-some-running (
b6f0: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
b700: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
b710: 73 65 74 75 70 22 20 22 67 69 76 65 2d 75 70 2d setup" "give-up-
b720: 77 61 69 74 69 6e 67 22 29 20 33 36 30 30 30 29 waiting") 36000)
b730: 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c )).. (hash-tabl
b740: 65 2d 73 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 e-set! *max-trie
b750: 73 2d 68 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d s-hash* tfullnam
b760: 65 20 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 e (+ (hash-table
b770: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 6d 61 -ref/default *ma
b780: 78 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 74 66 x-tries-hash* tf
b790: 75 6c 6c 6e 61 6d 65 20 30 29 20 31 29 29 29 0a ullname 0) 1))).
b7a0: 09 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .;; (debug:print
b7b0: 20 30 20 22 6d 61 78 2d 74 72 69 65 73 2d 68 61 0 "max-tries-ha
b7c0: 73 68 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c sh: " (hash-tabl
b7d0: 65 2d 3e 61 6c 69 73 74 20 2a 6d 61 78 2d 74 72 e->alist *max-tr
b7e0: 69 65 73 2d 68 61 73 68 2a 29 29 0a 0a 09 3b 3b ies-hash*))...;;
b7f0: 20 45 6e 73 75 72 65 20 61 6c 6c 20 74 6f 70 20 Ensure all top
b800: 6c 65 76 65 6c 20 74 65 73 74 73 20 67 65 74 20 level tests get
b810: 72 65 67 69 73 74 65 72 65 64 2e 20 54 68 69 73 registered. This
b820: 20 77 61 79 20 74 68 65 79 20 73 68 6f 77 20 75 way they show u
b830: 70 20 61 73 20 22 4e 4f 54 5f 53 54 41 52 54 45 p as "NOT_STARTE
b840: 44 22 20 6f 6e 20 74 68 65 20 64 61 73 68 62 6f D" on the dashbo
b850: 61 72 64 0a 09 3b 3b 20 61 6e 64 20 69 74 20 69 ard..;; and it i
b860: 73 20 63 6c 65 61 72 20 74 68 65 79 20 2a 73 68 s clear they *sh
b870: 6f 75 6c 64 2a 20 68 61 76 65 20 72 75 6e 20 62 ould* have run b
b880: 75 74 20 64 69 64 20 6e 6f 74 2e 0a 09 28 69 66 ut did not...(if
b890: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
b8a0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
b8b0: 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a st-registry (db:
b8c0: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
b8d0: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 ame test-name ""
b8e0: 29 20 23 66 29 29 0a 09 20 20 20 20 28 62 65 67 ) #f)).. (beg
b8f0: 69 6e 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 67 in.. (rmt:g
b900: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 eneral-call 'reg
b910: 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 ister-test run-i
b920: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
b930: 6d 65 20 22 22 29 0a 09 20 20 20 20 20 20 28 68 me "").. (h
b940: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
b950: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 est-registry (db
b960: 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
b970: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 name test-name "
b980: 22 29 20 27 64 6f 6e 65 29 29 29 0a 09 0a 09 3b ") 'done)))....;
b990: 3b 20 46 61 73 74 20 73 6b 69 70 20 6f 66 20 74 ; Fast skip of t
b9a0: 65 73 74 73 20 74 68 61 74 20 61 72 65 20 61 6c ests that are al
b9b0: 72 65 61 64 79 20 22 43 4f 4d 50 4c 45 54 45 44 ready "COMPLETED
b9c0: 22 20 2d 20 4e 4f 21 20 43 61 6e 6e 6f 74 20 64 " - NO! Cannot d
b9d0: 6f 20 74 68 61 74 20 61 73 20 74 68 65 20 69 74 o that as the it
b9e0: 65 6d 73 20 6d 61 79 20 6e 6f 74 20 68 61 76 65 ems may not have
b9f0: 20 62 65 65 6e 20 65 78 70 61 6e 64 65 64 20 79 been expanded y
ba00: 65 74 20 3a 28 0a 09 3b 3b 0a 09 28 69 66 20 28 et :(..;;..(if (
ba10: 6d 65 6d 62 65 72 20 28 68 61 73 68 2d 74 61 62 member (hash-tab
ba20: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
ba30: 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 66 75 est-registry tfu
ba40: 6c 6c 6e 61 6d 65 20 23 66 29 20 0a 09 09 20 20 llname #f) ...
ba50: 20 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 6d '(DONOTRUN rem
ba60: 6f 76 65 64 29 29 20 3b 3b 20 2a 63 6f 6d 6d 6f oved)) ;; *commo
ba70: 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 n:cant-run-state
ba80: 73 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 43 4f 4d s-sym*) ;; '(COM
ba90: 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 41 PLETED KILLED WA
baa0: 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e 43 IVED UNKNOWN INC
bab0: 4f 4d 50 4c 45 54 45 29 29 0a 09 20 20 20 20 28 OMPLETE)).. (
bac0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 69 66 begin.. (if
bad0: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
bae0: 28 63 6f 6e 63 20 22 62 65 65 6e 20 6d 61 72 6b (conc "been mark
baf0: 65 64 20 64 6f 20 6e 6f 74 20 72 75 6e 20 22 20 ed do not run "
bb00: 74 66 75 6c 6c 6e 61 6d 65 29 20 36 30 29 0a 09 tfullname) 60)..
bb10: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
bb20: 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 info 0 "Skipping
bb30: 20 74 65 73 74 20 22 20 74 66 75 6c 6c 6e 61 6d test " tfullnam
bb40: 65 20 22 20 61 73 20 69 74 20 68 61 73 20 62 65 e " as it has be
bb50: 65 6e 20 6d 61 72 6b 65 64 20 64 6f 20 6e 6f 74 en marked do not
bb60: 20 72 75 6e 20 64 75 65 20 74 6f 20 62 65 69 6e run due to bein
bb70: 67 20 63 6f 6d 70 6c 65 74 65 64 20 6f 72 20 6e g completed or n
bb80: 6f 74 20 72 75 6e 6e 61 62 6c 65 22 29 29 0a 09 ot runnable"))..
bb90: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
bba0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 ot (null? tal))(
bbb0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 not (null? reg))
bbc0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 75 6e )... (loop (run
bbd0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 s:queue-next-hed
bbe0: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
bbf0: 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 75 6e regfull)....(run
bc00: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
bc10: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
bc20: 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 75 6e regfull)....(run
bc30: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
bc40: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
bc50: 72 65 67 66 75 6c 6c 29 0a 09 09 09 72 65 72 75 regfull)....reru
bc60: 6e 73 29 29 29 29 0a 09 09 20 20 3b 3b 20 28 6c ns))))... ;; (l
bc70: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
bc80: 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e r tal) reg rerun
bc90: 73 29 29 29 29 0a 0a 09 28 64 65 62 75 67 3a 70 s))))...(debug:p
bca0: 72 69 6e 74 20 34 20 22 54 4f 50 20 4f 46 20 4c rint 4 "TOP OF L
bcb0: 4f 4f 50 20 3d 3e 20 22 0a 09 09 20 20 20 20 20 OOP => "...
bcc0: 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 "test-name: " te
bcd0: 73 74 2d 6e 61 6d 65 0a 09 09 20 20 20 20 20 22 st-name... "
bce0: 5c 6e 20 20 74 65 73 74 2d 72 65 63 6f 72 64 20 \n test-record
bcf0: 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 0a 09 " test-record..
bd00: 09 20 20 20 20 20 22 5c 6e 20 20 68 65 64 3a 20 . "\n hed:
bd10: 20 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 09 " hed...
bd20: 20 20 20 20 20 22 5c 6e 20 20 69 74 65 6d 64 61 "\n itemda
bd30: 74 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 74 t: " itemdat
bd40: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 74 65 ... "\n ite
bd50: 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 6d ms: " item
bd60: 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 74 s... "\n it
bd70: 65 6d 2d 70 61 74 68 3a 20 20 20 22 20 69 74 65 em-path: " ite
bd80: 6d 2d 70 61 74 68 0a 09 09 20 20 20 20 20 22 5c m-path... "\
bd90: 6e 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 20 20 n waitons:
bda0: 22 20 77 61 69 74 6f 6e 73 0a 09 09 20 20 20 20 " waitons...
bdb0: 20 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 69 65 "\n num-retrie
bdc0: 73 3a 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 s: " num-retries
bdd0: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 74 61 6c ... "\n tal
bde0: 3a 20 20 20 20 20 20 20 20 20 22 20 74 61 6c 0a : " tal.
bdf0: 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 72 75 .. "\n reru
be00: 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 75 6e ns: " rerun
be10: 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 s... "\n re
be20: 67 66 75 6c 6c 3a 20 20 20 20 20 22 20 72 65 67 gfull: " reg
be30: 66 75 6c 6c 0a 09 09 20 20 20 20 20 22 5c 6e 20 full... "\n
be40: 20 72 65 67 6c 65 6e 3a 20 20 20 20 20 20 22 20 reglen: "
be50: 72 65 67 6c 65 6e 0a 09 09 20 20 20 20 20 22 5c reglen... "\
be60: 6e 20 20 6c 65 6e 67 74 68 20 72 65 67 3a 20 20 n length reg:
be70: 22 20 28 6c 65 6e 67 74 68 20 72 65 67 29 0a 09 " (length reg)..
be80: 09 20 20 20 20 20 22 5c 6e 20 20 72 65 67 3a 20 . "\n reg:
be90: 20 20 20 20 20 20 20 20 22 20 72 65 67 29 0a 0a " reg)..
bea0: 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 .;; check for he
beb0: 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 d in waitons =>
bec0: 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 this would be ci
bed0: 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 rcular, remove i
bee0: 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 t and issue an..
bef0: 3b 3b 20 65 72 72 6f 72 0a 09 28 69 66 20 28 6d ;; error..(if (m
bf00: 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 20 ember test-name
bf10: 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 62 waitons).. (b
bf20: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
bf30: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
bf40: 52 3a 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e R: test " test-n
bf50: 61 6d 65 20 22 20 68 61 73 20 6c 69 73 74 65 64 ame " has listed
bf60: 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 itself as a wai
bf70: 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 ton, please corr
bf80: 65 63 74 20 74 68 69 73 21 22 29 0a 09 20 20 20 ect this!")..
bf90: 20 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e 20 (set! waiton
bfa0: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
bfb0: 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (x)(not (equal?
bfc0: 78 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 x hed))) waitons
bfd0: 29 29 29 29 0a 0a 09 28 63 6f 6e 64 20 0a 09 20 ))))...(cond ..
bfe0: 0a 09 20 3b 3b 20 57 65 20 77 61 6e 74 20 74 6f .. ;; We want to
bff0: 20 63 61 74 63 68 20 74 65 73 74 73 20 74 68 61 catch tests tha
c000: 74 20 68 61 76 65 20 77 61 69 74 6f 6e 73 20 74 t have waitons t
c010: 68 61 74 20 61 72 65 20 4e 4f 54 20 69 6e 20 74 hat are NOT in t
c020: 68 65 20 71 75 65 75 65 20 61 6e 64 20 64 69 73 he queue and dis
c030: 63 61 72 64 20 74 68 65 6d 20 49 46 46 20 0a 09 card them IFF ..
c040: 20 3b 3b 20 74 68 65 79 20 68 61 76 65 20 62 65 ;; they have be
c050: 65 6e 20 74 68 72 6f 75 67 68 20 74 68 65 20 77 en through the w
c060: 72 69 6e 67 65 72 20 31 30 20 6f 72 20 6d 6f 72 ringer 10 or mor
c070: 65 20 74 69 6d 65 73 0a 09 20 28 28 61 6e 64 20 e times.. ((and
c080: 28 6c 69 73 74 3f 20 77 61 69 74 6f 6e 73 29 0a (list? waitons).
c090: 09 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 . (not (nu
c0a0: 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 29 0a 09 20 ll? waitons))..
c0b0: 20 20 20 20 20 20 28 3e 20 28 68 61 73 68 2d 74 (> (hash-t
c0c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
c0d0: 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 *max-tries-hash
c0e0: 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 30 29 20 31 * tfullname 0) 1
c0f0: 30 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 0).. (not
c100: 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 0a 09 (null? (filter..
c110: 09 09 20 20 20 20 6e 75 6d 62 65 72 3f 0a 09 09 .. number?...
c120: 09 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
c130: 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 09 20 a (waiton).....
c140: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
c150: 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 (member waiton t
c160: 61 6c 29 29 20 20 20 20 20 20 20 20 20 20 20 20 al))
c170: 3b 3b 20 74 68 69 73 20 77 61 69 74 6f 6e 20 69 ;; this waiton i
c180: 73 20 6e 6f 74 20 69 6e 20 74 68 65 20 6c 69 73 s not in the lis
c190: 74 20 74 6f 20 62 65 20 74 72 69 65 64 20 74 6f t to be tried to
c1a0: 20 72 75 6e 0a 09 09 09 09 09 20 20 20 20 28 6e run...... (n
c1b0: 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f ot (member waito
c1c0: 6e 20 72 65 72 75 6e 73 29 29 29 0a 09 09 09 09 n reruns))).....
c1d0: 20 20 20 20 20 20 20 31 0a 09 09 09 09 20 20 20 1.....
c1e0: 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 77 61 #f))..... wa
c1f0: 69 74 6f 6e 73 29 29 29 29 29 20 3b 3b 20 63 6f itons))))) ;; co
c200: 75 6c 64 20 64 6f 20 74 68 69 73 20 6d 6f 72 65 uld do this more
c210: 20 65 6c 65 67 61 6e 74 6c 79 20 77 69 74 68 20 elegantly with
c220: 61 20 6d 61 72 6b 65 72 2e 2e 2e 2e 0a 09 20 20 a marker......
c230: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
c240: 57 41 52 4e 49 4e 47 3a 20 4d 61 72 6b 69 6e 67 WARNING: Marking
c250: 20 74 65 73 74 20 22 20 74 66 75 6c 6c 6e 61 6d test " tfullnam
c260: 65 20 22 20 61 73 20 6e 6f 74 20 72 75 6e 6e 61 e " as not runna
c270: 62 6c 65 2e 20 49 74 20 69 73 20 77 61 69 74 69 ble. It is waiti
c280: 6e 67 20 6f 6e 20 74 65 73 74 73 20 74 68 61 74 ng on tests that
c290: 20 63 61 6e 6e 6f 74 20 62 65 20 72 75 6e 2e 20 cannot be run.
c2a0: 47 69 76 69 6e 67 20 75 70 20 6e 6f 77 2e 22 29 Giving up now.")
c2b0: 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
c2c0: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
c2d0: 72 79 20 74 66 75 6c 6c 6e 61 6d 65 20 27 72 65 ry tfullname 're
c2e0: 6d 6f 76 65 64 29 29 0a 0a 09 20 3b 3b 20 69 74 moved))... ;; it
c2f0: 65 6d 73 20 69 73 20 23 66 20 74 68 65 6e 20 74 ems is #f then t
c300: 68 65 20 74 65 73 74 20 69 73 20 6f 6b 20 74 6f he test is ok to
c310: 20 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 be handed off t
c320: 6f 20 6c 61 75 6e 63 68 20 28 62 75 74 20 6e 6f o launch (but no
c330: 74 20 62 65 66 6f 72 65 29 0a 09 20 3b 3b 20 0a t before).. ;; .
c340: 09 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 0a 09 . ((not items)..
c350: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
c360: 6e 66 6f 20 34 20 22 4f 55 54 45 52 20 43 4f 4e nfo 4 "OUTER CON
c370: 44 3a 20 28 6e 6f 74 20 69 74 65 6d 73 29 22 29 D: (not items)")
c380: 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f .. (if (and (no
c390: 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 t (tests:match t
c3a0: 65 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 est-patts (tests
c3b0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
c3c0: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
c3d0: 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 68 20 72 ord) item-path r
c3e0: 65 71 75 69 72 65 64 3a 20 72 65 71 75 69 72 65 equired: require
c3f0: 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 28 d-tests))... (
c400: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
c410: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
c420: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
c430: 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 ) reg reruns))..
c440: 20 20 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 (let ((loop-li
c450: 73 74 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 73 st (runs:process
c460: 2d 65 78 70 61 6e 64 65 64 2d 74 65 73 74 73 20 -expanded-tests
c470: 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 hed tal reg reru
c480: 6e 73 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c ns reglen regful
c490: 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 20 72 75 l test-record ru
c4a0: 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 nname test-name
c4b0: 69 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 6f item-path jobgro
c4c0: 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e up max-concurren
c4d0: 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 t-jobs run-id wa
c4e0: 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 itons item-path
c4f0: 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 61 testmode test-pa
c500: 74 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 tts required-tes
c510: 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ts test-registry
c520: 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 20 registry-mutex
c530: 66 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 72 75 flags keyvals ru
c540: 6e 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 6c n-info newtal al
c550: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
c560: 20 69 74 65 6d 6d 61 70 29 29 29 0a 09 20 20 20 itemmap)))..
c570: 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 20 28 (if loop-list (
c580: 61 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 2d apply loop loop-
c590: 6c 69 73 74 29 29 29 29 0a 0a 09 20 3b 3b 20 69 list))))... ;; i
c5a0: 74 65 6d 73 20 70 72 6f 63 65 73 73 65 64 20 69 tems processed i
c5b0: 6e 74 6f 20 61 20 6c 69 73 74 20 62 75 74 20 6e nto a list but n
c5c0: 6f 74 20 63 61 6d 65 20 69 6e 20 61 73 20 61 20 ot came in as a
c5d0: 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 65 73 list been proces
c5e0: 73 65 64 0a 09 20 3b 3b 0a 09 20 28 28 61 6e 64 sed.. ;;.. ((and
c5f0: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 20 (list? items)
c600: 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b 6e ;; thus we kn
c610: 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 65 ow our items are
c620: 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c 61 already calcula
c630: 74 65 64 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 ted.. (not
c640: 20 20 20 69 74 65 6d 64 61 74 29 29 20 20 3b 3b itemdat)) ;;
c650: 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 78 70 and not yet exp
c660: 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 20 6c anded into the l
c670: 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 74 6f ist of things to
c680: 20 62 65 20 64 6f 6e 65 0a 09 20 20 28 64 65 62 be done.. (deb
c690: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
c6a0: 22 4f 55 54 45 52 20 43 4f 4e 44 3a 20 28 61 6e "OUTER COND: (an
c6b0: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 d (list? items)(
c6c0: 6e 6f 74 20 69 74 65 6d 64 61 74 29 29 22 29 0a not itemdat))").
c6d0: 09 20 20 3b 3b 20 4d 75 73 74 20 64 65 74 65 72 . ;; Must deter
c6e0: 6d 69 6e 65 20 69 66 20 74 68 65 20 69 74 65 6d mine if the item
c6f0: 73 20 6c 69 73 74 20 69 73 20 76 61 6c 69 64 2e s list is valid.
c700: 20 44 69 73 63 61 72 64 20 74 68 65 20 74 65 73 Discard the tes
c710: 74 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a t if it is not..
c720: 09 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 . (if (and (lis
c730: 74 3f 20 69 74 65 6d 73 29 0a 09 09 20 20 20 28 t? items)... (
c740: 3e 20 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 29 > (length items)
c750: 20 30 29 0a 09 09 20 20 20 28 61 6e 64 20 28 6c 0)... (and (l
c760: 69 73 74 3f 20 28 63 61 72 20 69 74 65 6d 73 29 ist? (car items)
c770: 29 0a 09 09 09 28 3e 20 28 6c 65 6e 67 74 68 20 )....(> (length
c780: 28 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 29 (car items)) 0))
c790: 0a 09 09 20 20 20 28 64 65 62 75 67 3a 64 65 62 ... (debug:deb
c7a0: 75 67 2d 6d 6f 64 65 20 31 29 29 0a 09 20 20 20 ug-mode 1))..
c7b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
c7c0: 32 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 2 (map (lambda (
c7d0: 72 6f 77 29 0a 09 09 09 09 20 20 20 20 28 63 6f row)..... (co
c7e0: 6e 63 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 nc (string-inter
c7f0: 73 70 65 72 73 65 0a 09 09 09 09 09 20 20 20 28 sperse...... (
c800: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 76 61 72 map (lambda (var
c810: 76 61 6c 29 0a 09 09 09 09 09 09 20 20 28 73 74 val)....... (st
c820: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
c830: 20 76 61 72 76 61 6c 20 22 3d 22 29 29 0a 09 09 varval "="))...
c840: 09 09 09 09 72 6f 77 29 0a 09 09 09 09 09 20 20 ....row)......
c850: 20 22 20 22 29 0a 09 09 09 09 09 20 20 22 5c 6e " ")...... "\n
c860: 22 29 29 0a 09 09 09 09 20 20 69 74 65 6d 73 29 "))..... items)
c870: 29 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a )).. (for-each.
c880: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 79 2d . (lambda (my-
c890: 69 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 28 itemdat).. (
c8a0: 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d let* ((new-test-
c8b0: 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 6e 65 record (let ((ne
c8c0: 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 74 73 wrec (make-tests
c8d0: 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a 09 09 :testqueue)))...
c8e0: 09 09 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 .. (vector
c8f0: 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 6f -copy! test-reco
c900: 72 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 20 rd newrec).....
c910: 20 20 20 20 20 20 6e 65 77 72 65 63 29 29 0a 09 newrec))..
c920: 09 20 20 20 20 28 6d 79 2d 69 74 65 6d 2d 70 61 . (my-item-pa
c930: 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 th (item-list->p
c940: 61 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 ath my-itemdat))
c950: 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 74 ).. (if (t
c960: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
c970: 70 61 74 74 73 20 68 65 64 20 6d 79 2d 69 74 65 patts hed my-ite
c980: 6d 2d 70 61 74 68 20 72 65 71 75 69 72 65 64 3a m-path required:
c990: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
c9a0: 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d ;; (patt-list-m
c9b0: 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 74 atch my-item-pat
c9c0: 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 20 h item-patts)
c9d0: 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 ;; yes,
c9e0: 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 65 we want to proce
c9f0: 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e 4f ss this item, NO
ca00: 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 6e TE: Should not n
ca10: 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 68 eed this check h
ca20: 65 72 65 21 0a 09 09 20 20 20 28 6c 65 74 20 28 ere!... (let (
ca30: 28 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 64 62 (newtestname (db
ca40: 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
ca50: 6e 61 6d 65 20 68 65 64 20 6d 79 2d 69 74 65 6d name hed my-item
ca60: 2d 70 61 74 68 29 29 29 20 20 20 20 3b 3b 20 74 -path))) ;; t
ca70: 65 73 74 20 6e 61 6d 65 73 20 61 72 65 20 75 6e est names are un
ca80: 69 71 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d 65 ique on testname
ca90: 2f 69 74 65 6d 2d 70 61 74 68 0a 09 09 20 20 20 /item-path...
caa0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
cab0: 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 20 20 ue-set-items!
cac0: 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 new-test-recor
cad0: 64 20 23 66 29 0a 09 09 20 20 20 20 20 28 74 65 d #f)... (te
cae0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
caf0: 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 77 t-itemdat! new
cb00: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d -test-record my-
cb10: 69 74 65 6d 64 61 74 29 0a 09 09 20 20 20 20 20 itemdat)...
cb20: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
cb30: 2d 73 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 -set-item_path!
cb40: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
cb50: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 my-item-path)...
cb60: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
cb70: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 -set! test-recor
cb80: 64 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 6e ds newtestname n
cb90: 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 0a ew-test-record).
cba0: 09 09 20 20 20 20 20 28 73 65 74 21 20 74 61 6c .. (set! tal
cbb0: 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 (append tal (li
cbc0: 73 74 20 6e 65 77 74 65 73 74 6e 61 6d 65 29 29 st newtestname))
cbd0: 29 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 ))))) ;; since t
cbe0: 68 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 hese are itemize
cbf0: 64 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 d create new tes
cc00: 74 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 t names testname
cc10: 2f 69 74 65 6d 70 61 74 68 0a 09 20 20 20 69 74 /itempath.. it
cc20: 65 6d 73 29 0a 0a 09 20 20 3b 3b 20 28 64 65 62 ems)... ;; (deb
cc30: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
cc40: 22 54 65 73 74 20 22 20 28 74 65 73 74 73 3a 74 "Test " (tests:t
cc50: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
cc60: 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 tname test-recor
cc70: 64 29 20 22 20 69 73 20 69 74 65 6d 69 7a 65 64 d) " is itemized
cc80: 20 62 75 74 20 68 61 73 20 6e 6f 20 69 74 65 6d but has no item
cc90: 73 22 29 0a 0a 09 20 20 3b 3b 20 41 74 20 74 68 s")... ;; At th
cca0: 69 73 20 70 6f 69 6e 74 20 77 65 20 68 61 76 65 is point we have
ccb0: 20 70 6f 73 73 69 62 6c 79 20 61 64 64 65 64 20 possibly added
ccc0: 69 74 65 6d 73 20 74 6f 20 74 61 6c 20 62 75 74 items to tal but
ccd0: 20 61 6c 6c 20 6d 75 73 74 20 62 65 20 68 61 6e all must be han
cce0: 64 65 64 20 6f 66 66 20 74 6f 20 0a 09 20 20 3b ded off to .. ;
ccf0: 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 6c 6f 67 ; INNER COND log
cd00: 69 63 2e 20 49 20 74 68 69 6e 6b 20 6c 6f 6f 70 ic. I think loop
cd10: 20 77 69 74 68 6f 75 74 20 72 6f 74 61 74 69 6e without rotatin
cd20: 67 20 74 68 65 20 71 75 65 75 65 20 0a 09 20 20 g the queue ..
cd30: 3b 3b 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c ;; (loop hed tal
cd40: 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 reg reruns))..
cd50: 20 3b 3b 20 28 6c 65 74 20 28 28 6e 65 77 74 61 ;; (let ((newta
cd60: 6c 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c l (append tal (l
cd70: 69 73 74 20 68 65 64 29 29 29 29 20 20 3b 3b 20 ist hed)))) ;;
cd80: 57 65 20 73 68 6f 75 6c 64 20 64 69 73 63 61 72 We should discar
cd90: 64 20 68 65 64 20 61 73 20 69 74 20 68 61 73 20 d hed as it has
cda0: 62 65 65 6e 20 65 78 70 61 6e 64 65 64 20 69 6e been expanded in
cdb0: 74 6f 20 69 74 27 73 20 69 74 65 6d 73 3f 20 59 to it's items? Y
cdc0: 65 73 2c 20 62 75 74 20 6f 6e 6c 79 20 69 66 20 es, but only if
cdd0: 74 68 69 73 20 2a 69 73 2a 20 61 6e 20 69 74 65 this *is* an ite
cde0: 6d 69 7a 65 64 20 74 65 73 74 0a 09 20 20 3b 3b mized test.. ;;
cdf0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt
ce00: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal)
ce10: 72 65 67 20 72 65 72 75 6e 73 29 0a 09 20 20 28 reg reruns).. (
ce20: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
ce30: 20 20 20 20 20 20 23 66 0a 09 20 20 20 20 20 20 #f..
ce40: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
ce50: 63 64 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 cdr tal) reg rer
ce60: 75 6e 73 29 29 29 0a 09 20 20 20 20 0a 09 20 3b uns))).. .. ;
ce70: 3b 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 20 ; if items is a
ce80: 70 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 74 proc then need t
ce90: 6f 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 2d o run items:get-
cea0: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
ceb0: 67 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 20 g, get the list
cec0: 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 3b 3b 20 20 and loop .. ;;
ced0: 20 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 - but only do
cee0: 74 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 that if resource
cef0: 73 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 s exist to kick
cf00: 6f 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 3b 3b off the job.. ;;
cf10: 20 45 58 50 41 4e 44 20 49 54 45 4d 53 0a 09 20 EXPAND ITEMS..
cf20: 28 28 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f ((or (procedure?
cf30: 20 69 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d items)(eq? item
cf40: 73 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 s 'have-procedur
cf50: 65 29 29 0a 09 20 20 28 6c 65 74 20 28 28 63 61 e)).. (let ((ca
cf60: 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 72 n-run-more (r
cf70: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
cf80: 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 20 6a 6f -tests run-id jo
cf90: 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 bgroup max-concu
cfa0: 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a 09 20 rrent-jobs)))..
cfb0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 (if (and (lis
cfc0: 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 t? can-run-more)
cfd0: 0a 09 09 20 20 20 20 20 28 63 61 72 20 63 61 6e ... (car can
cfe0: 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 28 6c -run-more))...(l
cff0: 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 20 28 et ((loop-list (
d000: 72 75 6e 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d runs:expand-item
d010: 73 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 s hed tal reg re
d020: 72 75 6e 73 20 72 65 67 66 75 6c 6c 20 6e 65 77 runs regfull new
d030: 74 61 6c 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 tal jobgroup max
d040: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
d050: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
d060: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f item-path testmo
d070: 64 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 63 de test-record c
d080: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 69 74 65 6d an-run-more item
d090: 73 20 72 75 6e 6e 61 6d 65 20 74 63 6f 6e 66 69 s runname tconfi
d0a0: 67 20 72 65 67 6c 65 6e 20 74 65 73 74 2d 72 65 g reglen test-re
d0b0: 67 69 73 74 72 79 20 74 65 73 74 2d 72 65 63 6f gistry test-reco
d0c0: 72 64 73 20 69 74 65 6d 6d 61 70 29 29 29 0a 09 rds itemmap)))..
d0d0: 09 20 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 . (if loop-list
d0e0: 0a 09 09 20 20 20 20 20 20 28 61 70 70 6c 79 20 ... (apply
d0f0: 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c 69 73 74 29 29 loop loop-list))
d100: 29 0a 09 09 3b 3b 20 69 66 20 63 61 6e 27 74 20 )...;; if can't
d110: 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 6c 6f run more just lo
d120: 6f 70 20 77 69 74 68 20 6e 65 78 74 20 70 6f 73 op with next pos
d130: 73 69 62 6c 65 20 74 65 73 74 0a 09 09 28 6c 6f sible test...(lo
d140: 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 op (car newtal)(
d150: 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 20 cdr newtal) reg
d160: 72 65 72 75 6e 73 29 29 29 29 0a 09 20 20 20 20 reruns))))..
d170: 0a 09 20 3b 3b 20 74 68 69 73 20 63 61 73 65 20 .. ;; this case
d180: 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 70 65 should not happe
d190: 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 65 6c 70 n, added to help
d1a0: 20 63 61 74 63 68 20 61 6e 79 20 62 75 67 73 0a catch any bugs.
d1b0: 09 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 . ((and (list? i
d1c0: 74 65 6d 73 29 20 69 74 65 6d 64 61 74 29 0a 09 tems) itemdat)..
d1d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
d1e0: 20 22 45 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 "ERROR: Should
d1f0: 6e 6f 74 20 68 61 76 65 20 61 20 6c 69 73 74 20 not have a list
d200: 6f 66 20 69 74 65 6d 73 20 69 6e 20 61 20 74 65 of items in a te
d210: 73 74 20 61 6e 64 20 74 68 65 20 69 74 65 6d 73 st and the items
d220: 70 61 74 68 20 73 65 74 20 2d 20 70 6c 65 61 73 path set - pleas
d230: 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a e report this").
d240: 09 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 28 . (exit 1)).. (
d250: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 75 (not (null? reru
d260: 6e 73 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 ns)).. (let* ((
d270: 6e 65 77 6c 73 74 20 28 74 65 73 74 73 3a 66 69 newlst (tests:fi
d280: 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c lter-non-runnabl
d290: 65 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 e run-id tal tes
d2a0: 74 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 69 t-records)) ;; i
d2b0: 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 41 .e. not FAIL, WA
d2c0: 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 IVED, INCOMPLETE
d2d0: 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a , PASS, KILLED,.
d2e0: 09 09 20 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 .. (junked (lset
d2f0: 2d 64 69 66 66 65 72 65 6e 63 65 20 65 71 75 61 -difference equa
d300: 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 l? tal newlst)))
d310: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
d320: 6e 74 2d 69 6e 66 6f 20 34 20 22 66 75 6c 6c 20 nt-info 4 "full
d330: 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 69 66 drop through, if
d340: 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 73 20 reruns is less
d350: 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 6c 6c than 100 we will
d360: 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 68 65 force retry the
d370: 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 m, reruns=" reru
d380: 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c 29 ns ", tal=" tal)
d390: 0a 09 20 20 20 20 28 69 66 20 28 3c 20 6e 75 6d .. (if (< num
d3a0: 2d 72 65 74 72 69 65 73 20 6d 61 78 2d 72 65 74 -retries max-ret
d3b0: 72 69 65 73 29 0a 09 09 28 73 65 74 21 20 6e 65 ries)...(set! ne
d3c0: 77 6c 73 74 20 28 61 70 70 65 6e 64 20 72 65 72 wlst (append rer
d3d0: 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 0a 09 20 uns newlst)))..
d3e0: 20 20 20 28 73 65 74 21 20 6e 75 6d 2d 72 65 74 (set! num-ret
d3f0: 72 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 72 ries (+ num-retr
d400: 69 65 73 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 ies 1)).. ;;
d410: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
d420: 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 + 1 *global-delt
d430: 61 2a 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e a*)).. (if (n
d440: 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 ot (null? newlst
d450: 29 29 0a 09 09 3b 3b 20 73 69 6e 63 65 20 72 65 ))...;; since re
d460: 72 75 6e 73 20 68 61 76 65 20 62 65 65 6e 20 74 runs have been t
d470: 61 63 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 6c acked on to newl
d480: 73 74 20 63 72 65 61 74 65 20 6e 65 77 20 72 65 st create new re
d490: 72 75 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 runs from junked
d4a0: 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 ...(loop (car ne
d4b0: 77 6c 73 74 29 28 63 64 72 20 6e 65 77 6c 73 74 wlst)(cdr newlst
d4c0: 29 20 72 65 67 20 28 64 65 6c 65 74 65 2d 64 75 ) reg (delete-du
d4d0: 70 6c 69 63 61 74 65 73 20 6a 75 6e 6b 65 64 29 plicates junked)
d4e0: 29 29 29 29 0a 09 20 28 28 6e 6f 74 20 28 6e 75 )))).. ((not (nu
d4f0: 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 28 64 65 ll? tal)).. (de
d500: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
d510: 20 22 49 27 6d 20 70 72 65 74 74 79 20 73 75 72 "I'm pretty sur
d520: 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 e I shouldn't ge
d530: 74 20 68 65 72 65 2e 22 29 29 0a 09 20 28 28 6e t here.")).. ((n
d540: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 20 ot (null? reg))
d550: 3b 3b 20 63 6f 75 6c 64 20 77 65 20 67 65 74 20 ;; could we get
d560: 68 65 72 65 20 77 69 74 68 20 6c 65 66 74 6f 76 here with leftov
d570: 65 72 73 3f 0a 09 20 20 28 64 65 62 75 67 3a 70 ers?.. (debug:p
d580: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 48 61 76 rint-info 0 "Hav
d590: 65 20 6c 65 66 74 6f 76 65 72 73 21 22 29 0a 09 e leftovers!")..
d5a0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 67 (loop (car reg
d5b0: 29 28 63 64 72 20 72 65 67 29 20 27 28 29 20 72 )(cdr reg) '() r
d5c0: 65 72 75 6e 73 29 29 0a 09 20 28 65 6c 73 65 0a eruns)).. (else.
d5d0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
d5e0: 69 6e 66 6f 20 34 20 22 45 78 69 74 69 6e 67 20 info 4 "Exiting
d5f0: 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 loop with...\n
d600: 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 hed=" hed "\n t
d610: 61 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 20 72 65 al=" tal "\n re
d620: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a runs=" reruns)).
d630: 09 20 29 29 29 0a 20 20 20 20 3b 3b 20 6e 6f 77 . ))). ;; now
d640: 20 2a 69 66 2a 20 2d 72 75 6e 2d 77 61 69 74 20 *if* -run-wait
d650: 77 65 20 77 61 69 74 20 66 6f 72 20 61 6c 6c 20 we wait for all
d660: 74 65 73 74 73 20 74 6f 20 62 65 20 64 6f 6e 65 tests to be done
d670: 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 77 61 69 74 . ;; Now wait
d680: 20 66 6f 72 20 61 6e 79 20 52 55 4e 4e 49 4e 47 for any RUNNING
d690: 20 74 65 73 74 73 20 74 6f 20 63 6f 6d 70 6c 65 tests to comple
d6a0: 74 65 20 28 69 66 20 69 6e 20 72 75 6e 2d 77 61 te (if in run-wa
d6b0: 69 74 20 6d 6f 64 65 29 0a 20 20 20 20 28 6c 65 it mode). (le
d6c0: 74 20 77 61 69 74 2d 6c 6f 6f 70 20 28 28 6e 75 t wait-loop ((nu
d6d0: 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 28 m-running (
d6e0: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
d6f0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
d700: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 29 0a run-id run-id)).
d710: 09 09 20 20 20 20 28 70 72 65 76 2d 6e 75 6d 2d .. (prev-num-
d720: 72 75 6e 6e 69 6e 67 20 30 29 29 0a 20 20 20 20 running 0)).
d730: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
d740: 74 20 30 20 22 6e 75 6d 2d 72 75 6e 6e 69 6e 67 t 0 "num-running
d750: 3d 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 22 =" num-running "
d760: 2c 20 70 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 , prev-num-runni
d770: 6e 67 3d 22 20 70 72 65 76 2d 6e 75 6d 2d 72 75 ng=" prev-num-ru
d780: 6e 6e 69 6e 67 29 0a 20 20 20 20 20 20 28 69 66 nning). (if
d790: 20 28 61 6e 64 20 28 6f 72 20 28 61 72 67 73 3a (and (or (args:
d7a0: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 77 61 get-arg "-run-wa
d7b0: 69 74 22 29 0a 09 09 20 20 20 28 65 71 75 61 6c it")... (equal
d7c0: 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ? (configf:looku
d7d0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
d7e0: 65 74 75 70 22 20 22 72 75 6e 2d 77 61 69 74 22 etup" "run-wait"
d7f0: 29 20 22 79 65 73 22 29 29 0a 09 20 20 20 20 20 ) "yes"))..
d800: 20 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (> num-running
d810: 20 30 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 0)).. (begin..
d820: 20 20 20 20 3b 3b 20 48 65 72 65 20 77 65 20 6d ;; Here we m
d830: 61 72 6b 20 61 6e 79 20 6f 6c 64 20 64 65 66 75 ark any old defu
d840: 6e 63 74 20 74 65 73 74 73 20 61 73 20 69 6e 63 nct tests as inc
d850: 6f 6d 70 6c 65 74 65 2e 20 44 6f 20 74 68 69 73 omplete. Do this
d860: 20 65 76 65 72 79 20 66 69 66 74 65 65 6e 20 6d every fifteen m
d870: 69 6e 75 74 65 73 0a 09 20 20 20 20 3b 3b 20 28 inutes.. ;; (
d880: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 47 debug:print 0 "G
d890: 6f 74 20 68 65 72 65 20 65 68 21 20 6e 75 6d 2d ot here eh! num-
d8a0: 72 75 6e 6e 69 6e 67 3d 22 20 6e 75 6d 2d 72 75 running=" num-ru
d8b0: 6e 6e 69 6e 67 20 22 20 28 3e 20 6e 75 6d 2d 72 nning " (> num-r
d8c0: 75 6e 6e 69 6e 67 20 30 29 20 22 20 28 3e 20 6e unning 0) " (> n
d8d0: 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 29 0a 09 um-running 0))..
d8e0: 20 20 20 20 28 69 66 20 28 3e 20 28 63 75 72 72 (if (> (curr
d8f0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 6c ent-seconds)(+ l
d900: 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c ast-time-incompl
d910: 65 74 65 20 39 30 30 29 29 0a 09 09 28 62 65 67 ete 900))...(beg
d920: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
d930: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 72 6b int-info 0 "Mark
d940: 69 6e 67 20 73 74 75 63 6b 20 74 65 73 74 73 20 ing stuck tests
d950: 61 73 20 49 4e 43 4f 4d 50 4c 45 54 45 20 77 68 as INCOMPLETE wh
d960: 69 6c 65 20 77 61 69 74 69 6e 67 20 66 6f 72 20 ile waiting for
d970: 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 2e 20 run " run-id ".
d980: 52 75 6e 6e 69 6e 67 20 61 73 20 70 69 64 20 22 Running as pid "
d990: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
d9a0: 73 2d 69 64 29 20 22 20 6f 6e 20 22 20 28 67 65 s-id) " on " (ge
d9b0: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 09 t-host-name))...
d9c0: 20 20 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d (set! last-tim
d9d0: 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 28 63 75 e-incomplete (cu
d9e0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
d9f0: 09 09 20 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e .. (rmt:find-an
da00: 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 d-mark-incomplet
da10: 65 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 09 e run-id #f)))..
da20: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
da30: 3f 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 70 72 ? num-running pr
da40: 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 ev-num-running))
da50: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
da60: 69 6e 66 6f 20 30 20 22 72 75 6e 2d 77 61 69 74 info 0 "run-wait
da70: 20 73 70 65 63 69 66 69 65 64 2c 20 77 61 69 74 specified, wait
da80: 69 6e 67 20 6f 6e 20 22 20 6e 75 6d 2d 72 75 6e ing on " num-run
da90: 6e 69 6e 67 20 22 20 74 65 73 74 73 20 69 6e 20 ning " tests in
daa0: 52 55 4e 4e 49 4e 47 2c 20 52 45 4d 4f 54 45 48 RUNNING, REMOTEH
dab0: 4f 53 54 53 54 41 52 54 20 6f 72 20 4c 41 55 4e OSTSTART or LAUN
dac0: 43 48 45 44 20 73 74 61 74 65 20 61 74 20 22 20 CHED state at "
dad0: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 (time->string (s
dae0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
daf0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
db00: 6e 64 73 29 29 29 29 29 0a 09 20 20 20 20 28 74 nds))))).. (t
db10: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a hread-sleep! 5).
db20: 09 20 20 20 20 3b 3b 20 28 77 61 69 74 2d 6c 6f . ;; (wait-lo
db30: 6f 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e op (rmt:get-coun
db40: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
db50: 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 for-run-id run-i
db60: 64 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 d) num-running))
db70: 29 29 0a 09 20 20 20 20 28 77 61 69 74 2d 6c 6f )).. (wait-lo
db80: 6f 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e op (rmt:get-coun
db90: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
dba0: 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 for-run-id run-i
dbb0: 64 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 d) num-running))
dbc0: 29 29 0a 20 20 20 20 3b 3b 20 4c 45 54 2a 20 28 )). ;; LET* (
dbd0: 28 74 65 73 74 2d 72 65 63 6f 72 64 0a 20 20 20 (test-record.
dbe0: 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 20 ;; we get here
dbf0: 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 68 on "drop through
dc00: 22 2e 20 41 6c 6c 20 64 6f 6e 65 21 0a 20 20 20 ". All done!.
dc10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
dc20: 66 6f 20 31 20 22 41 6c 6c 20 74 65 73 74 73 20 fo 1 "All tests
dc30: 6c 61 75 6e 63 68 65 64 22 29 29 29 0a 0a 28 64 launched")))..(d
dc40: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
dc50: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
dc60: 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 ot-met). (filte
dc70: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
dc80: 0a 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 .. (and (vect
dc90: 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 or? test) ;; not
dca0: 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 (string? test))
dcb0: 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a ... (equal? (db:
dcc0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
dcd0: 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 est) "COMPLETED"
dce0: 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 )... (not (membe
dcf0: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
dd00: 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 tatus test)....
dd10: 20 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 '("PASS" "W
dd20: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 ARN" "CHECK" "WA
dd30: 49 56 45 44 22 20 22 53 4b 49 50 22 29 29 29 29 IVED" "SKIP"))))
dd40: 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ).. prereqs-not
dd50: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
dd60: 28 72 75 6e 73 3a 63 61 6c 63 2d 70 72 65 72 65 (runs:calc-prere
dd70: 71 2d 66 61 69 6c 20 70 72 65 72 65 71 73 2d 6e q-fail prereqs-n
dd80: 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 ot-met). (filte
dd90: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
dda0: 0a 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 .. (and (vect
ddb0: 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 or? test) ;; not
ddc0: 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 (string? test))
ddd0: 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a ... (equal? (db:
dde0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
ddf0: 65 73 74 29 20 22 4e 4f 54 5f 53 54 41 52 54 45 est) "NOT_STARTE
de00: 44 22 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d D")... (not (mem
de10: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
de20: 2d 73 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 -status test)...
de30: 09 20 20 20 20 20 20 27 28 22 6e 2f 61 22 20 22 . '("n/a" "
de40: 4b 45 45 50 5f 54 52 59 49 4e 47 22 29 29 29 29 KEEP_TRYING"))))
de50: 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ).. prereqs-not
de60: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
de70: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
de80: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
de90: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
dea0: 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ter. (lambda (
deb0: 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 t). (or (not
dec0: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
ded0: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f (not (equal? "CO
dee0: 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 MPLETED" (db:tes
def0: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 t-get-state t)))
df00: 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f )). prereqs-no
df10: 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 t-met))..(define
df20: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d (runs:calc-not-
df30: 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 completed prereq
df40: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 s-not-met). (fi
df50: 6c 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 lter. (lambda
df60: 28 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f (t). (or (no
df70: 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 t (vector? t))..
df80: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 (not (equal? "C
df90: 4f 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 OMPLETED" (db:te
dfa0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 st-get-state t))
dfb0: 29 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e ))). prereqs-n
dfc0: 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e ot-met))..(defin
dfd0: 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 72 75 6e e (runs:calc-run
dfe0: 6e 61 62 6c 65 20 70 72 65 72 65 71 73 2d 6e 6f nable prereqs-no
dff0: 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 t-met). (filter
e000: 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 74 29 . (lambda (t)
e010: 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 . (or (not (
e020: 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 28 61 vector? t)).. (a
e030: 6e 64 20 28 65 71 75 61 6c 3f 20 22 4e 4f 54 5f nd (equal? "NOT_
e040: 53 54 41 52 54 45 44 22 20 28 64 62 3a 74 65 73 STARTED" (db:tes
e050: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 0a t-get-state t)).
e060: 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 . (member (
e070: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
e080: 75 73 20 74 29 0a 09 09 09 20 20 20 20 20 20 27 us t).... '
e090: 28 22 6e 2f 61 22 20 22 4b 45 45 50 5f 54 52 59 ("n/a" "KEEP_TRY
e0a0: 49 4e 47 22 29 29 29 29 29 0a 20 20 20 70 72 65 ING"))))). pre
e0b0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a reqs-not-met))..
e0c0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 (define (runs:pr
e0d0: 65 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 etty-string lst)
e0e0: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
e0f0: 28 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 (t).. (if (not (
e100: 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 vector? t))..
e110: 20 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 (conc t)..
e120: 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d (conc (db:test-
e130: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 get-testname t)
e140: 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ":" (db:test-get
e150: 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 -state t) "/" (d
e160: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
e170: 73 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c s t)))). l
e180: 73 74 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d st))..;; parent-
e190: 74 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 test is there as
e1a0: 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 a placeholder f
e1b0: 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 or when parent-t
e1c0: 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 ests can be run
e1d0: 61 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a as a setup step.
e1e0: 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 (define (run:tes
e1f0: 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 t run-id run-inf
e200: 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d o keyvals runnam
e210: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c e test-record fl
e220: 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 20 ags parent-test
e230: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 61 6c test-registry al
e240: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
e250: 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 ). ;; All these
e260: 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 vars might be r
e270: 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 eferenced by the
e280: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 testconfig file
e290: 20 72 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 reader. (let*
e2a0: 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 ((test-name (
e2b0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
e2c0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 get-testname t
e2d0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
e2e0: 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 test-waitons (te
e2f0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
e300: 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 t-waitons tes
e310: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
e320: 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 st-conf (test
e330: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
e340: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
e350: 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d record)).. (item
e360: 64 61 74 20 20 20 20 20 20 28 74 65 73 74 73 3a dat (tests:
e370: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
e380: 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 emdat test-re
e390: 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 cord)).. (test-p
e3a0: 61 74 68 20 20 20 20 28 68 61 73 68 2d 74 61 62 ath (hash-tab
e3b0: 6c 65 2d 72 65 66 20 61 6c 6c 2d 74 65 73 74 73 le-ref all-tests
e3c0: 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 2d 6e -registry test-n
e3d0: 61 6d 65 29 29 20 3b 3b 20 28 63 6f 6e 63 20 2a ame)) ;; (conc *
e3e0: 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 toppath* "/tests
e3f0: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b /" test-name)) ;
e400: 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 ; could use test
e410: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
e420: 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 here ..... (for
e430: 63 65 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ce (hash-
e440: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
e450: 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 t flags "-force"
e460: 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 #f)).. (rerun
e470: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
e480: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
e490: 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 ags "-rerun" #f)
e4a0: 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 ).. (keepgoing
e4b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
e4c0: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
e4d0: 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 "-keepgoing" #f)
e4e0: 29 0a 09 20 28 69 6e 63 6f 6d 70 6c 65 74 65 2d ).. (incomplete-
e4f0: 74 69 6d 65 6f 75 74 20 28 73 74 72 69 6e 67 2d timeout (string-
e500: 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e >number (or (con
e510: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
e520: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
e530: 22 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 "incomplete-time
e540: 6f 75 74 22 29 20 22 78 22 29 29 29 0a 09 20 28 out") "x"))).. (
e550: 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 22 22 item-path ""
e560: 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 ).. (db
e570: 20 20 23 66 29 0a 09 20 28 66 75 6c 6c 2d 74 65 #f).. (full-te
e580: 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 0a 20 20 st-name #f))..
e590: 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 65 ;; setting ite
e5a0: 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 69 mdat to a list i
e5b0: 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 28 f it is #f. (
e5c0: 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 if (not itemdat)
e5d0: 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 28 (set! itemdat '(
e5e0: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 74 ))). (set! it
e5f0: 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 em-path (item-li
e600: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
e610: 29 29 0a 20 20 20 20 28 73 65 74 21 20 66 75 6c )). (set! ful
e620: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a l-test-name (db:
e630: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
e640: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
e650: 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 64 em-path)). (d
e660: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
e670: 34 0a 09 09 20 20 20 20 20 20 22 5c 6e 54 45 53 4... "\nTES
e680: 54 4e 41 4d 45 3a 20 22 20 66 75 6c 6c 2d 74 65 TNAME: " full-te
e690: 73 74 2d 6e 61 6d 65 20 0a 09 09 20 20 20 20 20 st-name ...
e6a0: 20 22 5c 6e 20 20 20 74 65 73 74 2d 63 6f 6e 66 "\n test-conf
e6b0: 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c ig: " (hash-tabl
e6c0: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f e->alist test-co
e6d0: 6e 66 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 nf)... "\n
e6e0: 20 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 itemdat: " ite
e6f0: 6d 64 61 74 0a 09 09 20 20 20 20 20 20 29 0a 20 mdat... ).
e700: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
e710: 32 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 2 "Attempting to
e720: 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 66 launch test " f
e730: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 29 0a 20 ull-test-name).
e740: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 (setenv "MT_T
e750: 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e EST_NAME" test-n
e760: 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 ame) ;; . (se
e770: 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 tenv "MT_ITEMPAT
e780: 48 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 H" item-path).
e790: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
e7a0: 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d UNNAME" runnam
e7b0: 65 29 0a 20 20 20 20 28 72 75 6e 73 3a 73 65 74 e). (runs:set
e7c0: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
e7d0: 72 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e rs run-id inrunn
e7e0: 61 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b ame: runname) ;;
e7f0: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
e800: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
e810: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 ching process.
e820: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
e830: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a ory *toppath*)..
e840: 20 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 ;; Here is w
e850: 68 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 here the test_me
e860: 74 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 ta table is best
e870: 20 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 updated. ;;
e880: 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 Yes, another use
e890: 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 of a global for
e8a0: 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 caching. Need a
e8b0: 20 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 better way?.
e8c0: 20 3b 3b 0a 20 20 20 20 3b 3b 20 54 68 65 72 65 ;;. ;; There
e8d0: 20 69 73 20 6e 6f 77 20 61 20 73 69 6e 67 6c 65 is now a single
e8e0: 20 63 61 6c 6c 20 74 6f 20 72 75 6e 73 3a 75 70 call to runs:up
e8f0: 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 date-all-test_me
e900: 74 61 20 61 6e 64 20 74 68 69 73 20 0a 20 20 20 ta and this .
e910: 20 3b 3b 20 70 65 72 2d 74 65 73 74 20 63 61 6c ;; per-test cal
e920: 6c 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 2e l is not needed.
e930: 20 47 69 76 65 6e 20 74 68 65 20 64 65 6c 69 63 Given the delic
e940: 61 63 79 20 6f 66 20 74 68 65 20 6d 6f 76 65 20 acy of the move
e950: 74 6f 20 0a 20 20 20 20 3b 3b 20 76 31 2e 35 35 to . ;; v1.55
e960: 20 74 68 69 73 20 63 6f 64 65 20 69 73 20 62 65 this code is be
e970: 69 6e 67 20 6c 65 66 74 20 69 6e 20 70 6c 61 63 ing left in plac
e980: 65 20 66 6f 72 20 74 68 65 20 74 69 6d 65 20 62 e for the time b
e990: 65 69 6e 67 2e 0a 20 20 20 20 3b 3b 0a 20 20 20 eing.. ;;.
e9a0: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
e9b0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
e9c0: 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 t *test-meta-upd
e9d0: 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 ated* test-name
e9e0: 23 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 #f)). (be
e9f0: 67 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 gin.. (hash-ta
ea00: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d ble-set! *test-m
ea10: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
ea20: 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 t-name #t).
ea30: 20 20 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 (runs:upda
ea40: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 te-test_meta tes
ea50: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 t-name test-conf
ea60: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 ))). . ;;
ea70: 69 74 65 6d 64 61 74 20 3d 3e 20 28 28 72 69 70 itemdat => ((rip
ea80: 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 eness "overripe"
ea90: 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 ) (temperature "
eaa0: 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 cool") (season "
eab0: 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 6c summer")). (l
eac0: 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 et* ((new-test-p
ead0: 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 ath (string-inte
eae0: 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 rsperse (cons te
eaf0: 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 st-path (map cad
eb00: 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 r itemdat)) "/")
eb10: 29 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 ).. (test-id
eb20: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 (rmt:get-te
eb30: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
eb40: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
eb50: 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 )).. (testdat
eb60: 20 20 20 20 20 20 28 69 66 20 74 65 73 74 2d 69 (if test-i
eb70: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
eb80: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
eb90: 64 20 74 65 73 74 2d 69 64 29 20 23 66 29 29 29 d test-id) #f)))
eba0: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
ebb0: 74 65 73 74 64 61 74 29 0a 09 20 20 28 6c 65 74 testdat).. (let
ebc0: 20 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b loop ().. ;;
ebd0: 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 ensure that the
ebe0: 20 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 path exists bef
ebf0: 6f 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 ore registering
ec00: 74 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b the test.. ;;
ec10: 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 NOPE: Cannot! D
ec20: 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 on't know yet wh
ec30: 69 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 ich disk area wi
ec40: 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e ll be assigned..
ec50: 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 .... ;; (syst
ec60: 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 em (conc "mkdir
ec70: 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 -p " new-test-pa
ec80: 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 th)).. ;;..
ec90: 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ;; (open-run-c
eca0: 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 lose tests:regis
ecb0: 74 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d ter-test db run-
ecc0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
ecd0: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a m-path).. ;;.
ece0: 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 . ;; NB// for
ecf0: 20 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e the above line.
ed00: 20 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 I want the test
ed10: 20 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 to be registere
ed20: 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 d long before th
ed30: 69 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 is routine gets
ed40: 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a called!.. ;;.
ed50: 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 . (if (not te
ed60: 73 74 2d 69 64 29 28 73 65 74 21 20 74 65 73 74 st-id)(set! test
ed70: 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
ed80: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
ed90: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
eda0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
edb0: 20 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 test-id)...(beg
edc0: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
edd0: 69 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 int 2 "WARN: Tes
ede0: 74 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 t not pre-create
edf0: 64 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 d? test-name=" t
ee00: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d est-name ", item
ee10: 2d 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 -path=" item-pat
ee20: 68 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 h ", run-id=" ru
ee30: 6e 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a 67 n-id)... (rmt:g
ee40: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 eneral-call 'reg
ee50: 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 ister-test run-i
ee60: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
ee70: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 me item-path)...
ee80: 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 (set! test-id
ee90: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
eea0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
eeb0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a e item-path)))).
eec0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
eed0: 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 t-info 4 "test-i
eee0: 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 72 d=" test-id ", r
eef0: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
ef00: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
ef10: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
ef20: 70 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 path=\"" item-pa
ef30: 74 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 73 th "\"").. (s
ef40: 65 74 21 20 74 65 73 74 64 61 74 20 28 72 6d 74 et! testdat (rmt
ef50: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
ef60: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
ef70: 2d 69 64 29 29 0a 09 20 20 20 20 28 69 66 20 28 -id)).. (if (
ef80: 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 09 28 not testdat)...(
ef90: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
efa0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 :print-info 0 "W
efb0: 41 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 69 ARNING: server i
efc0: 73 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 74 72 s overloaded, tr
efd0: 79 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 6f 6e ying again in on
efe0: 65 20 73 65 63 6f 6e 64 22 29 0a 09 09 20 20 28 e second")... (
eff0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
f000: 0a 09 09 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a ... (loop))))).
f010: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 (if (not t
f020: 65 73 74 64 61 74 29 20 3b 3b 20 73 68 6f 75 6c estdat) ;; shoul
f030: 64 20 4e 4f 54 20 68 61 70 70 65 6e 0a 09 20 20 d NOT happen..
f040: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
f050: 45 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f ERROR: failed to
f060: 20 67 65 74 20 74 65 73 74 20 72 65 63 6f 72 64 get test record
f070: 20 66 6f 72 20 74 65 73 74 2d 69 64 20 22 20 74 for test-id " t
f080: 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 est-id)). (
f090: 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 62 set! test-id (db
f0a0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
f0b0: 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 69 66 tdat)). (if
f0c0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
f0d0: 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 63 68 est-path).. (ch
f0e0: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 ange-directory t
f0f0: 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 62 65 est-path).. (be
f100: 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a gin.. (debug:
f110: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 65 print "ERROR: te
f120: 73 74 20 72 75 6e 20 70 61 74 68 20 6e 6f 74 20 st run path not
f130: 63 72 65 61 74 65 64 20 62 65 66 6f 72 65 20 61 created before a
f140: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 75 6e ttempting to run
f150: 20 74 68 65 20 74 65 73 74 2e 20 50 65 72 68 61 the test. Perha
f160: 70 73 20 79 6f 75 20 61 72 65 20 72 75 6e 6e 69 ps you are runni
f170: 6e 67 20 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 20 ng -remove-runs
f180: 61 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 at the same time
f190: 3f 22 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 ?").. (change
f1a0: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
f1b0: 61 74 68 2a 29 29 29 0a 20 20 20 20 20 20 28 63 ath*))). (c
f1c0: 61 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b ase (if force ;;
f1d0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
f1e0: 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f -force")...'NOT_
f1f0: 53 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 STARTED...(if te
f200: 73 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 stdat... (str
f210: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 ing->symbol (tes
f220: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
f230: 64 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 dat))... 'fai
f240: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a led-to-insert)).
f250: 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 .((failed-to-ins
f260: 65 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 ert).. (debug:pr
f270: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 int 0 "ERROR: Fa
f280: 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 iled to insert t
f290: 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 he record into t
f2a0: 68 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f he db"))..((NOT_
f2b0: 53 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 STARTED COMPLETE
f2c0: 44 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 D DELETED).. (le
f2d0: 74 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 t ((runflag #f))
f2e0: 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 .. (cond..
f2f0: 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e ;; -force, run n
f300: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 o matter what..
f310: 20 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 (force (set!
f320: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
f330: 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 ;; NOT_STARTED
f340: 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 , run no matter
f350: 77 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 what.. ((memb
f360: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
f370: 74 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 te testdat) '("D
f380: 45 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 ELETED" "NOT_STA
f390: 52 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e RTED"))(set! run
f3a0: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
f3b0: 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 ; not -rerun and
f3c0: 20 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 PASS, WARN or C
f3d0: 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a HECK, do no run.
f3e0: 09 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 . ((and (or (
f3f0: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 not rerun)...
f400: 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 keepgoing)...
f410: 20 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 ;; Require to
f420: 66 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 force re-run for
f430: 20 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 COMPLETED or *a
f440: 6e 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c nything* + PASS,
f450: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 WARN or CHECK...
f460: 20 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 (or (member (t
f470: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
f480: 65 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 estdat) '("PASS"
f490: 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 "WARN" "CHECK"
f4a0: 22 53 4b 49 50 22 20 22 57 41 49 56 45 44 22 29 "SKIP" "WAIVED")
f4b0: 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 )... (membe
f4c0: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
f4d0: 65 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 e testdat) '("C
f4e0: 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 OMPLETED")))) ..
f4f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
f500: 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e t-info 2 "runnin
f510: 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 g test " test-na
f520: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
f530: 20 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 " suppressed as
f540: 20 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 it is " (test:g
f550: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
f560: 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a ) " and " (test:
f570: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
f580: 61 74 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 at)).. (hash
f590: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
f5a0: 2d 72 65 67 69 73 74 72 79 20 66 75 6c 6c 2d 74 -registry full-t
f5b0: 65 73 74 2d 6e 61 6d 65 20 27 44 4f 4e 4f 54 52 est-name 'DONOTR
f5c0: 55 4e 29 20 3b 3b 20 43 4f 4d 50 4c 45 54 45 44 UN) ;; COMPLETED
f5d0: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
f5e0: 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 nflag #f))..
f5f0: 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 ;; -rerun and st
f600: 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 atus is one of t
f610: 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e he specifed, run
f620: 20 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 72 it.. ((and r
f630: 65 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 erun... (let* (
f640: 28 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 72 (rerunlst (str
f650: 69 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 ing-split rerun
f660: 22 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 2d ",")).... (must-
f670: 72 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 rerun (member (t
f680: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
f690: 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 estdat) rerunlst
f6a0: 29 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 )))... (debug
f6b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d :print-info 3 "-
f6c0: 72 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 rerun list: " re
f6d0: 72 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 run ", test-stat
f6e0: 75 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d us: " (test:get-
f6f0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 22 status testdat)"
f700: 2c 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 , must-rerun: "
f710: 6d 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 must-rerun)...
f720: 20 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 must-rerun))..
f730: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
f740: 74 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 t-info 2 "Rerun
f750: 66 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 forced for test
f760: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
f770: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
f780: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
f790: 74 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 t)).. ;; -kee
f7a0: 70 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 pgoing, do not r
f7b0: 65 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 erun FAIL.. (
f7c0: 28 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 (and keepgoing..
f7d0: 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 . (member (test
f7e0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
f7f0: 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 dat) '("FAIL")))
f800: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
f810: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 flag #f)).. (
f820: 28 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 (and (not rerun)
f830: 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 ... (member (te
f840: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
f850: 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 stdat) '("FAIL"
f860: 22 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 "n/a"))).. (
f870: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
f880: 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 ).. (else (se
f890: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 t! runflag #f)))
f8a0: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
f8b0: 74 20 34 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 t 4 "RUNNING =>
f8c0: 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c runflag: " runfl
f8d0: 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 ag " STATE: " (t
f8e0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
f8f0: 73 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a stdat) " STATUS:
f900: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
f910: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 tus testdat))..
f920: 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c (if (not runfl
f930: 61 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 ag).. (if
f940: 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 (not parent-test
f950: 29 0a 09 09 20 20 20 28 69 66 20 28 72 75 6e 73 )... (if (runs
f960: 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 :lownoise (conc
f970: 22 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 "not starting te
f980: 73 74 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 st" full-test-na
f990: 6d 65 29 20 36 30 29 0a 09 09 20 20 20 20 20 20 me) 60)...
f9a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
f9b0: 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 "NOTE: Not start
f9c0: 69 6e 67 20 74 65 73 74 20 22 20 66 75 6c 6c 2d ing test " full-
f9d0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 test-name " as i
f9e0: 74 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 t is state \"" (
f9f0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
fa00: 65 73 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 estdat) .....
fa10: 20 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 "\" and status
fa20: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
fa30: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c atus testdat) "\
fa40: 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 ", use -rerun \"
fa50: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
fa60: 75 73 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 us testdat).....
fa70: 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 "\" or -forc
fa80: 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 e to override"))
fa90: 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 ).. ;; NOT
faa0: 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 E: No longer be
fab0: 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 checking prerequ
fac0: 69 73 69 74 65 73 20 68 65 72 65 21 20 57 69 6c isites here! Wil
fad0: 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 l never get here
fae0: 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 unless prereqs
faf0: 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 are.. ;;
fb00: 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 already met
fb10: 2e 0a 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 ... ;; Thi
fb20: 73 20 77 6f 75 6c 64 20 62 65 20 61 20 67 72 65 s would be a gre
fb30: 61 74 20 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 at place to do t
fb40: 68 65 20 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a he process-fork.
fb50: 09 20 20 20 20 20 20 20 3b 3b 20 0a 09 20 20 20 . ;; ..
fb60: 20 20 20 20 28 6c 65 74 20 28 28 73 6b 69 70 2d (let ((skip-
fb70: 74 65 73 74 20 20 20 23 66 29 0a 09 09 20 20 20 test #f)...
fb80: 20 20 28 73 6b 69 70 2d 63 68 65 63 6b 20 20 28 (skip-check (
fb90: 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 configf:get-sect
fba0: 69 6f 6e 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 ion test-conf "s
fbb0: 6b 69 70 22 29 29 29 0a 09 09 20 28 63 6f 6e 64 kip")))... (cond
fbc0: 20 0a 09 09 20 20 3b 3b 20 48 61 76 65 20 74 6f ... ;; Have to
fbd0: 20 63 68 65 63 6b 20 66 6f 72 20 73 6b 69 70 20 check for skip
fbe0: 63 6f 6e 64 69 74 69 6f 6e 73 2e 20 54 68 69 73 conditions. This
fbf0: 20 6f 6e 65 20 73 6b 69 70 73 20 69 66 20 74 68 one skips if th
fc00: 65 72 65 20 61 72 65 20 73 61 6d 65 2d 6e 61 6d ere are same-nam
fc10: 65 64 20 74 65 73 74 73 0a 09 09 20 20 3b 3b 20 ed tests... ;;
fc20: 63 75 72 72 65 6e 74 6c 79 20 72 75 6e 6e 69 6e currently runnin
fc30: 67 0a 09 09 20 20 28 28 61 6e 64 20 73 6b 69 70 g... ((and skip
fc40: 2d 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 69 -check....(confi
fc50: 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 gf:lookup test-c
fc60: 6f 6e 66 20 22 73 6b 69 70 22 20 22 70 72 65 76 onf "skip" "prev
fc70: 72 75 6e 6e 69 6e 67 22 29 29 0a 09 09 20 20 20 running"))...
fc80: 3b 3b 20 72 75 6e 2d 69 64 73 20 3d 20 23 66 20 ;; run-ids = #f
fc90: 6d 65 61 6e 73 20 2a 61 6c 6c 2a 20 72 75 6e 73 means *all* runs
fca0: 0a 09 09 20 20 20 28 6c 65 74 20 28 28 72 75 6e ... (let ((run
fcb0: 6e 69 6e 67 2d 74 65 73 74 73 20 28 72 6d 74 3a ning-tests (rmt:
fcc0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
fcd0: 6e 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 66 75 ns-mindata #f fu
fce0: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 ll-test-name '("
fcf0: 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 RUNNING" "REMOTE
fd00: 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e HOSTSTART" "LAUN
fd10: 43 48 45 44 22 29 20 27 28 29 20 23 66 29 29 29 CHED") '() #f)))
fd20: 0a 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ... (if (not
fd30: 20 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 6e 67 2d (null? running-
fd40: 74 65 73 74 73 29 29 20 3b 3b 20 68 61 76 65 20 tests)) ;; have
fd50: 74 6f 20 73 6b 69 70 20 0a 09 09 09 20 28 73 65 to skip .... (se
fd60: 74 21 20 73 6b 69 70 2d 74 65 73 74 20 22 53 6b t! skip-test "Sk
fd70: 69 70 70 69 6e 67 20 64 75 65 20 74 6f 20 70 72 ipping due to pr
fd80: 65 76 69 6f 75 73 20 74 65 73 74 73 20 72 75 6e evious tests run
fd90: 6e 69 6e 67 22 29 29 29 29 0a 09 09 20 20 28 28 ning"))))... ((
fda0: 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a 09 and skip-check..
fdb0: 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ..(configf:looku
fdc0: 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 p test-conf "ski
fdd0: 70 22 20 22 66 69 6c 65 65 78 69 73 74 73 22 29 p" "fileexists")
fde0: 29 0a 09 09 20 20 20 28 69 66 20 28 66 69 6c 65 )... (if (file
fdf0: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 66 69 67 -exists? (config
fe00: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f f:lookup test-co
fe10: 6e 66 20 22 73 6b 69 70 22 20 22 66 69 6c 65 65 nf "skip" "filee
fe20: 78 69 73 74 73 22 29 29 0a 09 09 20 20 20 20 20 xists"))...
fe30: 20 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 (set! skip-tes
fe40: 74 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 6e t (conc "Skippin
fe50: 67 20 64 75 65 20 74 6f 20 65 78 69 73 74 61 6e g due to existan
fe60: 63 65 20 6f 66 20 66 69 6c 65 20 22 20 28 63 6f ce of file " (co
fe70: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 nfigf:lookup tes
fe80: 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 t-conf "skip" "f
fe90: 69 6c 65 65 78 69 73 74 73 22 29 29 29 29 29 0a ileexists"))))).
fea0: 0a 09 09 20 20 28 28 61 6e 64 20 73 6b 69 70 2d ... ((and skip-
feb0: 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 69 67 check....(config
fec0: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f f:lookup test-co
fed0: 6e 66 20 22 73 6b 69 70 22 20 22 72 75 6e 64 65 nf "skip" "runde
fee0: 6c 61 79 22 29 29 0a 09 09 20 20 20 3b 3b 20 72 lay"))... ;; r
fef0: 75 6e 2d 69 64 73 20 3d 20 23 66 20 6d 65 61 6e un-ids = #f mean
ff00: 73 20 2a 61 6c 6c 2a 20 72 75 6e 73 0a 09 09 20 s *all* runs...
ff10: 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 73 65 63 (let* ((numsec
ff20: 6f 6e 64 73 20 20 20 20 20 20 28 63 6f 6d 6d 6f onds (commo
ff30: 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 65 n:hms-string->se
ff40: 63 6f 6e 64 73 20 28 63 6f 6e 66 69 67 66 3a 6c conds (configf:l
ff50: 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
ff60: 22 73 6b 69 70 22 20 22 72 75 6e 64 65 6c 61 79 "skip" "rundelay
ff70: 22 29 29 29 0a 09 09 09 20 20 28 72 75 6e 6e 69 "))).... (runni
ff80: 6e 67 2d 74 65 73 74 73 20 20 20 28 72 6d 74 3a ng-tests (rmt:
ff90: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
ffa0: 6e 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 66 75 ns-mindata #f fu
ffb0: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 ll-test-name '("
ffc0: 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 RUNNING" "REMOTE
ffd0: 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e HOSTSTART" "LAUN
ffe0: 43 48 45 44 22 29 20 27 28 29 20 23 66 29 29 0a CHED") '() #f)).
fff0: 09 09 09 20 20 28 63 6f 6d 70 6c 65 74 65 64 2d ... (completed-
10000 74 65 73 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 tests (rmt:get-t
10010 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 ests-for-runs-mi
10020 6e 64 61 74 61 20 23 66 20 66 75 6c 6c 2d 74 65 ndata #f full-te
10030 73 74 2d 6e 61 6d 65 20 27 28 22 43 4f 4d 50 4c st-name '("COMPL
10040 45 54 45 44 22 29 20 27 28 22 50 41 53 53 22 20 ETED") '("PASS"
10050 22 46 41 49 4c 22 20 22 41 42 4f 52 54 22 29 20 "FAIL" "ABORT")
10060 23 66 29 29 0a 09 09 09 20 20 28 6c 61 73 74 2d #f)).... (last-
10070 72 75 6e 2d 74 69 6d 65 73 20 20 28 6d 61 70 20 run-times (map
10080 64 62 3a 6d 69 6e 74 65 73 74 2d 67 65 74 2d 65 db:mintest-get-e
10090 76 65 6e 74 5f 74 69 6d 65 20 63 6f 6d 70 6c 65 vent_time comple
100a0 74 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 ted-tests))....
100b0 20 28 74 69 6d 65 2d 73 69 6e 63 65 2d 6c 61 73 (time-since-las
100c0 74 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 t (- (current-se
100d0 63 6f 6e 64 73 29 20 28 69 66 20 28 6e 75 6c 6c conds) (if (null
100e0 3f 20 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 73 ? last-run-times
100f0 29 20 30 20 28 61 70 70 6c 79 20 6d 61 78 20 6c ) 0 (apply max l
10100 61 73 74 2d 72 75 6e 2d 74 69 6d 65 73 29 29 29 ast-run-times)))
10110 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 6f ))... (if (o
10120 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 r (not (null? ru
10130 6e 6e 69 6e 67 2d 74 65 73 74 73 29 29 20 3b 3b nning-tests)) ;;
10140 20 68 61 76 65 20 74 6f 20 73 6b 69 70 20 69 66 have to skip if
10150 20 74 65 73 74 20 69 73 20 72 75 6e 6e 69 6e 67 test is running
10160 0a 09 09 09 20 20 20 20 20 28 3e 20 6e 75 6d 73 .... (> nums
10170 65 63 6f 6e 64 73 20 74 69 6d 65 2d 73 69 6e 63 econds time-sinc
10180 65 2d 6c 61 73 74 29 29 0a 09 09 09 20 28 73 65 e-last)).... (se
10190 74 21 20 73 6b 69 70 2d 74 65 73 74 20 28 63 6f t! skip-test (co
101a0 6e 63 20 22 53 6b 69 70 70 69 6e 67 20 64 75 65 nc "Skipping due
101b0 20 74 6f 20 70 72 65 76 69 6f 75 73 20 74 65 73 to previous tes
101c0 74 20 72 75 6e 20 6c 65 73 73 20 74 68 61 6e 20 t run less than
101d0 22 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 " (configf:looku
101e0 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 p test-conf "ski
101f0 70 22 20 22 72 75 6e 64 65 6c 61 79 22 29 20 22 p" "rundelay") "
10200 20 61 67 6f 22 29 29 29 29 29 29 0a 09 09 20 0a ago"))))))... .
10210 09 09 20 28 69 66 20 73 6b 69 70 2d 74 65 73 74 .. (if skip-test
10220 0a 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ... (begin..
10230 09 20 20 20 20 20 20 20 28 6d 74 3a 74 65 73 74 . (mt:test
10240 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
10250 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 s-by-id run-id t
10260 65 73 74 2d 69 64 20 22 43 4f 4d 50 4c 45 54 45 est-id "COMPLETE
10270 44 22 20 22 53 4b 49 50 22 20 73 6b 69 70 2d 74 D" "SKIP" skip-t
10280 65 73 74 29 0a 09 09 20 20 20 20 20 20 20 28 64 est)... (d
10290 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
102a0 31 20 22 53 4b 49 50 50 49 4e 47 20 54 65 73 74 1 "SKIPPING Test
102b0 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d " full-test-nam
102c0 65 20 22 20 64 75 65 20 74 6f 20 22 20 73 6b 69 e " due to " ski
102d0 70 2d 74 65 73 74 29 29 0a 09 09 20 20 20 20 20 p-test))...
102e0 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 (if (not (launch
102f0 2d 74 65 73 74 20 74 65 73 74 2d 69 64 20 72 75 -test test-id ru
10300 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 n-id run-info ke
10310 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 yvals runname te
10320 73 74 2d 63 6f 6e 66 20 74 65 73 74 2d 6e 61 6d st-conf test-nam
10330 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d e test-path item
10340 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 09 20 dat flags))....
10350 28 62 65 67 69 6e 0a 09 09 09 20 20 20 28 70 72 (begin.... (pr
10360 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c int "ERROR: Fail
10370 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 ed to launch the
10380 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 test. Exiting a
10390 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 s soon as possib
103a0 6c 65 22 29 0a 09 09 09 20 20 20 28 73 65 74 21 le").... (set!
103b0 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 *globalexitstat
103c0 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 09 20 20 us* 1) ;; ....
103d0 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
103e0 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
103f0 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c s-id) signal/kil
10400 6c 29 29 29 29 29 29 29 29 0a 09 28 28 4b 49 4c l))))))))..((KIL
10410 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 LED) .. (debug:p
10420 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 rint 1 "NOTE: "
10430 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 full-test-name "
10440 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e is already runn
10450 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 ing or was expli
10460 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 ctly killed, use
10470 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 -force to launc
10480 68 20 69 74 2e 22 29 0a 09 20 28 68 61 73 68 2d h it.").. (hash-
10490 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
104a0 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 registry (db:tes
104b0 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 t-make-full-name
104c0 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
104d0 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 path) 'DONOTRUN)
104e0 29 20 3b 3b 20 4b 49 4c 4c 45 44 29 29 0a 09 28 ) ;; KILLED))..(
104f0 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 (LAUNCHED REMOTE
10500 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e HOSTSTART RUNNIN
10510 47 29 20 20 0a 09 20 28 64 65 62 75 67 3a 70 72 G) .. (debug:pr
10520 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 int 2 "NOTE: " t
10530 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c est-name " is al
10540 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 ready running"))
10550 0a 09 3b 3b 20 28 69 66 20 28 3e 20 28 2d 20 28 ..;; (if (> (- (
10560 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
10570 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (+ (db:test-get-
10580 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 event_time testd
10590 61 74 29 0a 09 3b 3b 20 09 09 09 20 20 20 20 20 at)..;; ...
105a0 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
105b0 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 un_duration test
105c0 64 61 74 29 29 29 0a 09 3b 3b 20 09 28 6f 72 20 dat)))..;; .(or
105d0 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 6f incomplete-timeo
105e0 75 74 0a 09 3b 3b 20 09 20 20 20 20 36 30 30 30 ut..;; . 6000
105f0 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 )) ;; i.e. no up
10600 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 date for more th
10610 61 6e 20 36 30 30 30 20 73 65 63 6f 6e 64 73 0a an 6000 seconds.
10620 09 3b 3b 20 20 20 20 20 20 28 62 65 67 69 6e 0a .;; (begin.
10630 09 3b 3b 20 20 20 20 20 20 20 20 28 64 65 62 75 .;; (debu
10640 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
10650 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d NG: Test " test-
10660 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 name " appears t
10670 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 o be dead. Forci
10680 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 ng it to state I
10690 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 NCOMPLETE and st
106a0 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 atus STUCK/DEAD"
106b0 29 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 74 65 )..;; (te
106c0 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
106d0 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
106e0 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 -id "INCOMPLETE"
106f0 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 22 "STUCK/DEAD" ""
10700 20 23 66 29 29 0a 09 3b 3b 20 20 20 20 20 20 20 #f))..;;
10710 20 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 74 2d ;; (tests:test-
10720 73 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 74 set-status! test
10730 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 -id "INCOMPLETE"
10740 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 22 "STUCK/DEAD" ""
10750 20 23 66 29 29 0a 09 3b 3b 20 20 20 20 20 20 28 #f))..;; (
10760 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e debug:print 2 "N
10770 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 OTE: " test-name
10780 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 " is already ru
10790 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 nning")))..(else
107a0 20 20 20 20 20 20 0a 09 20 28 64 65 62 75 67 3a .. (debug:
107b0 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
107c0 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
107d0 20 74 65 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 test " full-tes
107e0 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f t-name ". Unreco
107f0 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 gnised state " (
10800 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
10810 65 73 74 64 61 74 29 29 0a 09 20 28 63 61 73 65 estdat)).. (case
10820 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
10830 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
10840 20 74 65 73 74 64 61 74 29 29 20 0a 09 20 20 20 testdat)) ..
10850 28 28 43 4f 4d 50 4c 45 54 45 44 20 49 4e 43 4f ((COMPLETED INCO
10860 4d 50 4c 45 54 45 29 0a 09 20 20 20 20 28 68 61 MPLETE).. (ha
10870 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
10880 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a st-registry (db:
10890 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
108a0 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 ame test-name te
108b0 73 74 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 st-path) 'DONOTR
108c0 55 4e 29 29 0a 09 20 20 20 28 65 6c 73 65 0a 09 UN)).. (else..
108d0 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
108e0 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
108f0 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 ry (db:test-make
10900 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
10910 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 29 20 name test-path)
10920 27 44 4f 4e 4f 54 52 55 4e 29 29 29 29 29 29 29 'DONOTRUN)))))))
10930 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
10940 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10950 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10960 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10970 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 ===========.;; E
10980 4e 44 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a ND OF NEW STUFF.
10990 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
109a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
109b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
109c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
109d0 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
109e0 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 e (get-dir-up-n
109f0 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 dir . params) .
10a00 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 (let ((dparts
10a10 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 (string-split di
10a20 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 r "/"))..(count
10a30 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 (if (null? par
10a40 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 61 ams) 1 (car para
10a50 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 ms)))). (conc
10a60 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 "/" (string-int
10a70 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 ersperse ..
10a80 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 (take dparts (
10a90 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 - (length dparts
10aa0 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 ) count))..
10ab0 20 20 22 2f 22 29 29 29 29 0a 0a 28 64 65 66 69 "/"))))..(defi
10ac0 6e 65 20 28 72 75 6e 73 3a 72 65 63 75 72 73 69 ne (runs:recursi
10ad0 76 65 2d 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 ve-delete-with-e
10ae0 72 72 6f 72 2d 6d 73 67 20 72 65 61 6c 2d 64 69 rror-msg real-di
10af0 72 29 0a 20 20 28 69 66 20 28 3e 20 28 73 79 73 r). (if (> (sys
10b00 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 tem (conc "rm -r
10b10 66 20 22 20 72 65 61 6c 2d 64 69 72 29 29 20 30 f " real-dir)) 0
10b20 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ). (begin..
10b30 3b 3b 20 46 41 49 4c 45 44 2c 20 70 6f 73 73 69 ;; FAILED, possi
10b40 62 6c 79 20 64 75 65 20 74 6f 20 70 65 72 6d 69 bly due to permi
10b50 73 73 69 6f 6e 73 2c 20 64 6f 20 63 68 6d 6f 64 ssions, do chmod
10b60 20 61 2b 72 77 78 20 74 68 65 6e 20 74 72 79 20 a+rwx then try
10b70 6f 6e 65 20 6d 6f 72 65 20 74 69 6d 65 0a 09 28 one more time..(
10b80 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 63 68 system (conc "ch
10b90 6d 6f 64 20 2d 52 20 61 2b 72 77 78 20 22 20 72 mod -R a+rwx " r
10ba0 65 61 6c 2d 64 69 72 29 29 0a 09 28 69 66 20 28 eal-dir))..(if (
10bb0 3e 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 > (system (conc
10bc0 22 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 "rm -rf " real-d
10bd0 69 72 29 29 20 30 29 0a 09 20 20 20 20 28 64 65 ir)) 0).. (de
10be0 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
10bf0 4f 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 20 OR: There was a
10c00 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 problem removing
10c10 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 77 69 " real-dir " wi
10c20 74 68 20 72 6d 20 2d 66 22 29 29 29 29 29 0a 0a th rm -f")))))..
10c30 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 61 (define (runs:sa
10c40 66 65 2d 64 65 6c 65 74 65 2d 74 65 73 74 2d 64 fe-delete-test-d
10c50 69 72 20 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b ir real-dir). ;
10c60 3b 20 66 69 72 73 74 20 64 65 6c 65 74 65 20 61 ; first delete a
10c70 6c 6c 20 73 75 62 2d 64 69 72 65 63 74 6f 72 69 ll sub-directori
10c80 65 73 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d es. (directory-
10c90 66 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 fold . (lambda
10ca0 20 28 66 20 78 29 0a 20 20 20 20 20 28 6c 65 74 (f x). (let
10cb0 20 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e ((fullname (con
10cc0 63 20 72 65 61 6c 2d 64 69 72 20 22 2f 22 20 66 c real-dir "/" f
10cd0 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 ))). (if (
10ce0 64 69 72 65 63 74 6f 72 79 3f 20 66 75 6c 6c 6e directory? fulln
10cf0 61 6d 65 29 28 72 75 6e 73 3a 72 65 63 75 72 73 ame)(runs:recurs
10d00 69 76 65 2d 64 65 6c 65 74 65 2d 77 69 74 68 2d ive-delete-with-
10d10 65 72 72 6f 72 2d 6d 73 67 20 66 75 6c 6c 6e 61 error-msg fullna
10d20 6d 65 29 29 29 0a 20 20 20 20 20 28 2b 20 31 20 me))). (+ 1
10d30 78 29 29 0a 20 20 20 30 20 72 65 61 6c 2d 64 69 x)). 0 real-di
10d40 72 29 0a 20 20 3b 3b 20 74 68 65 6e 20 66 69 6c r). ;; then fil
10d50 65 73 20 6f 74 68 65 72 20 74 68 61 6e 20 2a 74 es other than *t
10d60 65 73 74 64 61 74 2e 64 62 2a 0a 20 20 28 64 69 estdat.db*. (di
10d70 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 rectory-fold .
10d80 20 28 6c 61 6d 62 64 61 20 28 66 20 78 29 0a 20 (lambda (f x).
10d90 20 20 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 6e (let ((fulln
10da0 61 6d 65 20 28 63 6f 6e 63 20 72 65 61 6c 2d 64 ame (conc real-d
10db0 69 72 20 22 2f 22 20 66 29 29 29 0a 20 20 20 20 ir "/" f))).
10dc0 20 20 20 28 69 66 20 28 6e 6f 74 20 28 73 74 72 (if (not (str
10dd0 69 6e 67 2d 73 65 61 72 63 68 20 28 72 65 67 65 ing-search (rege
10de0 78 70 20 22 74 65 73 74 64 61 74 2e 64 62 22 29 xp "testdat.db")
10df0 20 66 29 29 0a 09 20 20 20 28 72 75 6e 73 3a 72 f)).. (runs:r
10e00 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d ecursive-delete-
10e10 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 66 with-error-msg f
10e20 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 ullname))).
10e30 28 2b 20 31 20 78 29 29 0a 20 20 20 30 20 72 65 (+ 1 x)). 0 re
10e40 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 68 65 al-dir). ;; the
10e50 6e 20 74 68 65 20 65 6e 74 69 72 65 20 64 69 72 n the entire dir
10e60 65 63 74 6f 72 79 0a 20 20 28 72 75 6e 73 3a 72 ectory. (runs:r
10e70 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d ecursive-delete-
10e80 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 72 with-error-msg r
10e90 65 61 6c 2d 64 69 72 29 29 0a 0a 3b 3b 20 52 65 eal-dir))..;; Re
10ea0 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 move runs.;; fie
10eb0 6c 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 lds are passing
10ec0 69 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 in through .;; a
10ed0 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 ction:.;; 're
10ee0 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 move-runs.;;
10ef0 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 'set-state-statu
10f00 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f s.;;.;; NB// sho
10f10 75 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 73 uld pass in keys
10f20 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 ?.;;.(define (ru
10f30 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 61 63 ns:operate-on ac
10f40 74 69 6f 6e 20 74 61 72 67 65 74 20 72 75 6e 6e tion target runn
10f50 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 74 amepatt testpatt
10f60 20 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 #!key (state #f
10f70 29 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 )(status #f)(new
10f80 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 -state-status #f
10f90 29 28 6d 6f 64 65 20 27 72 65 6d 6f 76 65 2d 61 )(mode 'remove-a
10fa0 6c 6c 29 28 6f 70 74 69 6f 6e 73 20 27 28 29 29 ll)(options '())
10fb0 29 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 ). (common:clea
10fc0 72 2d 63 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 r-caches) ;; cle
10fd0 61 72 20 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 ar all caches.
10fe0 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 (let* ((db
10ff0 20 20 20 20 20 23 66 29 0a 09 20 28 74 64 62 64 #f).. (tdbd
11000 61 74 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a at (tasks:
11010 6f 70 65 6e 2d 64 62 29 29 0a 09 20 28 6b 65 79 open-db)).. (key
11020 73 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 s (rmt:g
11030 65 74 2d 6b 65 79 73 29 29 0a 09 20 28 72 75 6e et-keys)).. (run
11040 64 61 74 20 20 20 20 20 20 20 28 6d 74 3a 67 65 dat (mt:ge
11050 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b t-runs-by-patt k
11060 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 eys runnamepatt
11070 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 target)).. (head
11080 65 72 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 er (vector
11090 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a -ref rundat 0)).
110a0 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 20 . (runs
110b0 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
110c0 61 74 20 31 29 29 0a 09 20 28 73 74 61 74 65 73 at 1)).. (states
110d0 20 20 20 20 20 20 20 28 69 66 20 73 74 61 74 65 (if state
110e0 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
110f0 73 74 61 74 65 20 20 22 2c 22 29 20 27 28 29 29 state ",") '())
11100 29 0a 09 20 28 73 74 61 74 75 73 65 73 20 20 20 ).. (statuses
11110 20 20 28 69 66 20 73 74 61 74 75 73 20 28 73 74 (if status (st
11120 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 75 ring-split statu
11130 73 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 s ",") '())).. (
11140 73 74 61 74 65 2d 73 74 61 74 75 73 20 28 69 66 state-status (if
11150 20 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 (string? new-st
11160 61 74 65 2d 73 74 61 74 75 73 29 20 28 73 74 72 ate-status) (str
11170 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 ing-split new-st
11180 61 74 65 2d 73 74 61 74 75 73 20 22 2c 22 29 20 ate-status ",")
11190 27 28 23 66 20 23 66 29 29 29 29 0a 20 20 20 20 '(#f #f)))).
111a0 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
111b0 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 o 4 "runs:operat
111c0 65 2d 6f 6e 20 3d 3e 20 48 65 61 64 65 72 3a 20 e-on => Header:
111d0 22 20 68 65 61 64 65 72 20 22 20 61 63 74 69 6f " header " actio
111e0 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 n: " action " ne
111f0 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 3a 20 w-state-status:
11200 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 " new-state-stat
11210 75 73 29 0a 20 20 20 20 28 69 66 20 28 3e 20 32 us). (if (> 2
11220 20 28 6c 65 6e 67 74 68 20 73 74 61 74 65 2d 73 (length state-s
11230 74 61 74 75 73 29 29 0a 09 28 62 65 67 69 6e 0a tatus))..(begin.
11240 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
11250 30 20 22 45 52 52 4f 52 3a 20 74 68 65 20 70 61 0 "ERROR: the pa
11260 72 61 6d 65 74 65 72 20 74 6f 20 2d 73 65 74 2d rameter to -set-
11270 73 74 61 74 65 2d 73 74 61 74 75 73 20 69 73 20 state-status is
11280 61 20 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 65 a comma delimite
11290 64 20 73 74 72 69 6e 67 2e 20 45 2e 67 2e 20 43 d string. E.g. C
112a0 4f 4d 50 4c 45 54 45 44 2c 46 41 49 4c 22 29 0a OMPLETED,FAIL").
112b0 09 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 . (exit))).
112c0 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
112d0 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 lambda (run).
112e0 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 (let ((runke
112f0 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 y (string-inters
11300 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 perse (map (lamb
11310 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 62 da (k).......(db
11320 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
11330 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
11340 6b 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a k)) keys) "/")).
11350 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 . (dirs-to-r
11360 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 emove (make-hash
11370 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 20 20 28 -table)).. (
11380 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 28 proc-get-tests (
11390 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a lambda (run-id).
113a0 09 09 09 20 20 20 20 20 20 28 6d 74 3a 67 65 74 ... (mt:get
113b0 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 -tests-for-run r
113c0 75 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 20 20 un-id.......
113d0 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
113e0 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 statuses.......
113f0 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 not-in: #f..
11400 09 09 09 09 09 20 20 20 20 73 6f 72 74 2d 62 79 ..... sort-by
11410 3a 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 : (case action..
11420 09 09 09 09 09 09 20 20 20 20 20 20 20 28 28 72 ...... ((r
11430 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e emove-runs) 'run
11440 64 69 72 29 0a 09 09 09 09 09 09 09 20 20 20 20 dir)........
11450 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 (else
11460 20 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 'event_time)))
11470 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 ))).. (let* ((ru
11480 6e 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d n-id (db:get-
11490 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
114a0 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
114b0 29 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 )...(run-state (
114c0 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
114d0 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
114e0 72 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 72 r "state"))...(r
114f0 75 6e 2d 6e 61 6d 65 20 20 28 64 62 3a 67 65 74 un-name (db:get
11500 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
11510 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
11520 6e 61 6d 65 22 29 29 0a 09 09 28 74 65 73 74 73 name"))...(tests
11530 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
11540 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 qual? run-state
11550 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 "locked"))....
11560 20 20 20 20 20 28 70 72 6f 63 2d 67 65 74 2d 74 (proc-get-t
11570 65 73 74 73 20 72 75 6e 2d 69 64 29 0a 09 09 09 ests run-id)....
11580 20 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 28 '()))...(
11590 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 lasttpath "/does
115a0 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 /not/exist/I/hop
115b0 65 22 29 0a 09 09 28 77 6f 72 6b 65 72 2d 74 68 e")...(worker-th
115c0 72 65 61 64 20 23 66 29 29 0a 09 20 20 20 28 64 read #f)).. (d
115d0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
115e0 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 4 "runs:operate-
115f0 6f 6e 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 on run=" run ",
11600 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 header=" header)
11610 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e .. (if (not (n
11620 75 6c 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 20 ull? tests))..
11630 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 (begin... (
11640 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 case action...
11650 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a ((remove-runs).
11660 09 09 20 20 20 20 28 69 66 20 28 74 61 73 6b 73 .. (if (tasks
11670 3a 6e 65 65 64 2d 73 65 72 76 65 72 20 72 75 6e :need-server run
11680 2d 69 64 29 28 74 61 73 6b 73 3a 73 74 61 72 74 -id)(tasks:start
11690 2d 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d 73 65 -and-wait-for-se
116a0 72 76 65 72 20 74 64 62 64 61 74 20 72 75 6e 2d rver tdbdat run-
116b0 69 64 20 31 30 29 29 0a 09 09 20 20 20 20 3b 3b id 10))... ;;
116c0 20 73 65 65 6b 20 61 6e 64 20 6b 69 6c 6c 20 69 seek and kill i
116d0 6e 20 66 6c 69 67 68 74 20 2d 72 75 6e 74 65 73 n flight -runtes
116e0 74 73 20 77 69 74 68 20 25 20 61 73 20 74 65 73 ts with % as tes
116f0 74 70 61 74 74 20 68 65 72 65 0a 09 09 20 20 20 tpatt here...
11700 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 65 73 (if (equal? tes
11710 74 70 61 74 74 20 22 25 22 29 0a 09 09 09 28 74 tpatt "%")....(t
11720 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 72 asks:kill-runner
11730 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 target run-name
11740 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e )....(debug:prin
11750 74 20 30 20 22 6e 6f 74 20 61 74 74 65 6d 70 74 t 0 "not attempt
11760 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 61 6e 79 20 ing to kill any
11770 72 75 6e 20 6c 61 75 6e 63 68 65 72 20 70 72 6f run launcher pro
11780 63 65 73 73 65 73 20 61 73 20 74 65 73 74 70 61 cesses as testpa
11790 74 74 20 69 73 20 22 20 74 65 73 74 70 61 74 74 tt is " testpatt
117a0 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a ))... (debug:
117b0 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e print 1 "Removin
117c0 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a g tests for run:
117d0 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
117e0 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
117f0 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
11800 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
11810 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 ((set-state-s
11820 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 69 66 tatus)... (if
11830 20 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 (tasks:need-ser
11840 76 65 72 20 72 75 6e 2d 69 64 29 28 74 61 73 6b ver run-id)(task
11850 73 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 s:start-and-wait
11860 2d 66 6f 72 2d 73 65 72 76 65 72 20 74 64 62 64 -for-server tdbd
11870 61 74 20 72 75 6e 2d 69 64 20 31 30 29 29 0a 09 at run-id 10))..
11880 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
11890 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 t 1 "Modifying s
118a0 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 tate and staus f
118b0 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e or tests for run
118c0 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
118d0 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
118e0 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
118f0 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 r "runname")))..
11900 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 . ((print-run)
11910 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
11920 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 20 int 1 "Printing
11930 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 info for run " r
11940 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 unkey ", run=" r
11950 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 65 un ", tests=" te
11960 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 20 sts ", header="
11970 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 63 header)... ac
11980 74 69 6f 6e 29 0a 09 09 20 20 20 28 28 72 75 6e tion)... ((run
11990 2d 77 61 69 74 29 0a 09 09 20 20 20 20 28 64 65 -wait)... (de
119a0 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 61 69 bug:print 1 "Wai
119b0 74 69 6e 67 20 66 6f 72 20 72 75 6e 20 22 20 72 ting for run " r
119c0 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 unkey ", run=" r
119d0 75 6e 6e 61 6d 65 70 61 74 74 20 22 20 74 6f 20 unnamepatt " to
119e0 63 6f 6d 70 6c 65 74 65 22 29 29 0a 09 09 20 20 complete"))...
119f0 20 28 28 61 72 63 68 69 76 65 29 0a 09 09 20 20 ((archive)...
11a00 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
11a10 20 22 41 72 63 68 69 76 69 6e 67 2f 72 65 73 74 "Archiving/rest
11a20 6f 72 69 6e 67 20 28 22 20 28 61 72 67 73 3a 67 oring (" (args:g
11a30 65 74 2d 61 72 67 20 22 2d 61 72 63 68 69 76 65 et-arg "-archive
11a40 22 29 20 22 29 20 64 61 74 61 20 66 6f 72 20 72 ") ") data for r
11a50 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
11a60 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
11a70 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
11a80 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a der "runname")).
11a90 09 09 20 20 20 20 28 73 65 74 21 20 77 6f 72 6b .. (set! work
11aa0 65 72 2d 74 68 72 65 61 64 20 28 6d 61 6b 65 2d er-thread (make-
11ab0 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
11ac0 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 )....... (
11ad0 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
11ae0 6d 62 6f 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 mbol (args:get-a
11af0 72 67 20 22 2d 61 72 63 68 69 76 65 22 29 29 0a rg "-archive")).
11b00 09 09 09 09 09 09 09 20 28 28 73 61 76 65 20 73 ....... ((save s
11b10 61 76 65 2d 72 65 6d 6f 76 65 20 6b 65 65 70 2d ave-remove keep-
11b20 68 74 6d 6c 29 28 61 72 63 68 69 76 65 3a 72 75 html)(archive:ru
11b30 6e 2d 62 75 70 20 28 61 72 67 73 3a 67 65 74 2d n-bup (args:get-
11b40 61 72 67 20 22 2d 61 72 63 68 69 76 65 22 29 20 arg "-archive")
11b50 72 75 6e 2d 69 64 20 72 75 6e 2d 6e 61 6d 65 20 run-id run-name
11b60 74 65 73 74 73 29 29 0a 09 09 09 09 09 09 09 20 tests))........
11b70 28 28 72 65 73 74 6f 72 65 29 28 61 72 63 68 69 ((restore)(archi
11b80 76 65 3a 62 75 70 2d 72 65 73 74 6f 72 65 20 28 ve:bup-restore (
11b90 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 args:get-arg "-a
11ba0 72 63 68 69 76 65 22 29 20 72 75 6e 2d 69 64 20 rchive") run-id
11bb0 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 73 29 29 run-name tests))
11bc0 0a 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 0a ........ (else .
11bd0 09 09 09 09 09 09 09 20 20 28 64 65 62 75 67 3a ....... (debug:
11be0 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
11bf0 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 75 62 unrecognised sub
11c00 20 63 6f 6d 6d 61 6e 64 20 74 6f 20 2d 61 72 63 command to -arc
11c10 68 69 76 65 2e 20 52 75 6e 20 5c 22 6d 65 67 61 hive. Run \"mega
11c20 74 65 73 74 5c 22 20 74 6f 20 73 65 65 20 68 65 test\" to see he
11c30 6c 70 22 29 0a 09 09 09 09 09 09 09 20 20 28 65 lp")........ (e
11c40 78 69 74 29 29 29 29 0a 09 09 09 09 09 09 20 20 xit)))).......
11c50 20 20 20 22 61 72 63 68 69 76 65 2d 62 75 70 2d "archive-bup-
11c60 74 68 72 65 61 64 22 29 29 0a 09 09 20 20 20 20 thread"))...
11c70 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 77 (thread-start! w
11c80 6f 72 6b 65 72 2d 74 68 72 65 61 64 29 29 0a 09 orker-thread))..
11c90 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 . (else...
11ca0 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
11cb0 6f 20 30 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 o 0 "action not
11cc0 72 65 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 recognised " act
11cd0 69 6f 6e 29 29 29 0a 09 09 20 0a 09 09 20 3b 3b ion)))... ... ;;
11ce0 20 61 63 74 69 6f 6e 73 20 74 68 61 74 20 6f 70 actions that op
11cf0 65 72 61 74 65 20 6f 6e 20 6f 6e 65 20 74 65 73 erate on one tes
11d00 74 20 61 74 20 61 20 74 69 6d 65 20 63 61 6e 20 t at a time can
11d10 62 65 20 68 61 6e 64 6c 65 64 20 62 65 6c 6f 77 be handled below
11d20 0a 09 09 20 3b 3b 0a 09 09 20 28 6c 65 74 20 28 ... ;;... (let (
11d30 28 73 6f 72 74 65 64 2d 74 65 73 74 73 20 20 20 (sorted-tests
11d40 20 20 28 66 69 6c 74 65 72 20 0a 09 09 09 09 09 (filter ......
11d50 20 20 76 65 63 74 6f 72 3f 0a 09 09 09 09 09 20 vector?......
11d60 20 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 (sort tests (la
11d70 6d 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 mbda (a b)(let (
11d80 28 64 69 72 61 20 3b 3b 20 28 72 6d 74 3a 73 64 (dira ;; (rmt:sd
11d90 62 2d 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 b-qry 'getstr ..
11da0 09 09 09 09 09 09 09 09 20 20 28 64 62 3a 74 65 ........ (db:te
11db0 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 29 st-get-rundir a)
11dc0 29 20 3b 3b 20 29 20 20 3b 3b 20 28 66 69 6c 65 ) ;; ) ;; (file
11dd0 64 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 62 db:get-path *fdb
11de0 2a 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 * (db:test-get-r
11df0 75 6e 64 69 72 20 61 29 29 29 0a 09 09 09 09 09 undir a)))......
11e00 09 09 09 09 20 28 64 69 72 62 20 3b 3b 20 28 72 .... (dirb ;; (r
11e10 6d 74 3a 73 64 62 2d 71 72 79 20 27 67 65 74 73 mt:sdb-qry 'gets
11e20 74 72 20 0a 09 09 09 09 09 09 09 09 09 20 20 28 tr .......... (
11e30 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
11e40 69 72 20 62 29 29 29 20 3b 3b 20 29 20 3b 3b 20 ir b))) ;; ) ;;
11e50 28 28 66 69 6c 65 64 62 3a 67 65 74 2d 70 61 74 ((filedb:get-pat
11e60 68 20 2a 66 64 62 2a 20 28 64 62 3a 74 65 73 74 h *fdb* (db:test
11e70 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 29 -get-rundir b)))
11e80 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 28 )......... (
11e90 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
11ea0 20 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 dira)(string? d
11eb0 69 72 62 29 29 0a 09 09 09 09 09 09 09 09 09 20 irb))..........
11ec0 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
11ed0 68 20 64 69 72 61 29 28 73 74 72 69 6e 67 2d 6c h dira)(string-l
11ee0 65 6e 67 74 68 20 64 69 72 62 29 29 0a 09 09 09 ength dirb))....
11ef0 09 09 09 09 09 09 20 23 66 29 29 29 29 29 29 0a ...... #f)))))).
11f00 09 09 20 20 20 20 20 20 20 28 74 6f 70 6c 65 76 .. (toplev
11f10 65 6c 2d 72 65 74 72 69 65 73 20 28 6d 61 6b 65 el-retries (make
11f20 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
11f30 20 74 72 79 20 74 68 72 65 65 20 74 69 6d 65 73 try three times
11f40 20 74 6f 20 6c 6f 6f 70 20 74 68 72 6f 75 67 68 to loop through
11f50 20 61 6e 64 20 72 65 6d 6f 76 65 20 74 6f 70 20 and remove top
11f60 6c 65 76 65 6c 20 74 65 73 74 73 0a 09 09 20 20 level tests...
11f70 20 20 20 20 20 28 74 65 73 74 2d 72 65 74 72 79 (test-retry
11f80 2d 74 69 6d 65 20 20 28 6d 61 6b 65 2d 68 61 73 -time (make-has
11f90 68 2d 74 61 62 6c 65 29 29 0a 09 09 20 20 20 20 h-table))...
11fa0 20 20 20 28 61 6c 6c 6f 77 2d 72 75 6e 2d 74 69 (allow-run-ti
11fb0 6d 65 20 20 20 31 30 29 29 20 3b 3b 20 73 65 63 me 10)) ;; sec
11fc0 6f 6e 64 73 20 74 6f 20 61 6c 6c 6f 77 20 66 6f onds to allow fo
11fd0 72 20 6b 69 6c 6c 69 6e 67 20 74 65 73 74 73 20 r killing tests
11fe0 62 65 66 6f 72 65 20 6a 75 73 74 20 62 72 75 74 before just brut
11ff0 61 6c 6c 79 20 6b 69 6c 6c 69 6e 67 20 27 65 6d ally killing 'em
12000 0a 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ... (let loop
12010 28 28 74 65 73 74 20 28 63 61 72 20 73 6f 72 74 ((test (car sort
12020 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 20 ed-tests))....
12030 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 73 (tal (cdr s
12040 6f 72 74 65 64 2d 74 65 73 74 73 29 29 29 0a 09 orted-tests)))..
12050 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 . (let* ((te
12060 73 74 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a st-id (db:
12070 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
12080 29 29 0a 09 09 09 20 20 20 20 28 6e 65 77 2d 74 )).... (new-t
12090 65 73 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 est-dat (rmt:ge
120a0 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
120b0 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
120c0 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 )))... (if
120d0 20 28 6e 6f 74 20 6e 65 77 2d 74 65 73 74 2d 64 (not new-test-d
120e0 61 74 29 0a 09 09 09 20 20 20 28 62 65 67 69 6e at).... (begin
120f0 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
12100 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
12110 57 65 20 68 61 76 65 20 61 20 74 65 73 74 2d 69 We have a test-i
12120 64 20 6f 66 20 22 20 74 65 73 74 2d 69 64 20 22 d of " test-id "
12130 20 62 75 74 20 6e 6f 20 72 65 63 6f 72 64 20 77 but no record w
12140 61 73 20 66 6f 75 6e 64 2e 20 4e 4f 54 45 3a 20 as found. NOTE:
12150 4e 6f 20 6c 6f 63 6b 69 6e 67 20 6f 66 20 72 65 No locking of re
12160 63 6f 72 64 73 20 69 73 20 64 6f 6e 65 20 62 65 cords is done be
12170 74 77 65 65 6e 20 70 72 6f 63 65 73 73 65 73 2c tween processes,
12180 20 64 6f 20 6e 6f 74 20 73 69 6d 75 6c 74 61 6e do not simultan
12190 65 6f 75 73 6c 79 20 72 65 6d 6f 76 65 20 74 68 eously remove th
121a0 65 20 73 61 6d 65 20 72 75 6e 20 66 72 6f 6d 20 e same run from
121b0 74 77 6f 20 70 72 6f 63 65 73 73 65 73 21 22 29 two processes!")
121c0 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f .... (if (no
121d0 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
121e0 09 09 09 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 ... (loop (car t
121f0 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a al)(cdr tal)))).
12200 09 09 09 20 20 20 28 6c 65 74 2a 20 28 28 69 74 ... (let* ((it
12210 65 6d 2d 70 61 74 68 20 20 20 20 20 28 64 62 3a em-path (db:
12220 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
12230 74 68 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 th new-test-dat)
12240 29 0a 09 09 09 09 20 20 28 74 65 73 74 2d 6e 61 )..... (test-na
12250 6d 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d me (db:test-
12260 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 6e 65 77 get-testname new
12270 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 -test-dat)).....
12280 20 20 28 72 75 6e 2d 64 69 72 20 20 20 20 20 20 (run-dir
12290 20 3b 3b 28 66 69 6c 65 64 62 3a 67 65 74 2d 70 ;;(filedb:get-p
122a0 61 74 68 20 2a 66 64 62 2a 0a 09 09 09 09 20 20 ath *fdb*.....
122b0 20 3b 3b 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 ;; (rmt:sdb-qry
122c0 20 27 67 65 74 69 64 20 0a 09 09 09 09 20 20 20 'getid .....
122d0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
122e0 64 69 72 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 dir new-test-dat
122f0 29 29 20 3b 3b 20 29 20 20 20 20 3b 3b 20 72 75 )) ;; ) ;; ru
12300 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 n dir is from th
12310 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 09 e link tree.....
12320 20 20 28 74 65 73 74 2d 73 74 61 74 65 20 20 20 (test-state
12330 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
12340 61 74 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 ate new-test-dat
12350 29 29 0a 09 09 09 09 20 20 28 74 65 73 74 2d 66 ))..... (test-f
12360 75 6c 6c 6e 20 20 20 20 28 64 62 3a 74 65 73 74 ulln (db:test
12370 2d 67 65 74 2d 66 75 6c 6c 6e 61 6d 65 20 6e 65 -get-fullname ne
12380 77 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 w-test-dat))....
12390 09 20 20 28 75 6e 61 6d 65 20 20 20 20 20 20 20 . (uname
123a0 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 75 (db:test-get-u
123b0 6e 61 6d 65 20 20 20 20 6e 65 77 2d 74 65 73 74 name new-test
123c0 2d 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 6f -dat))..... (to
123d0 70 6c 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c plevel-with-chil
123e0 64 72 65 6e 20 28 61 6e 64 20 28 64 62 3a 74 65 dren (and (db:te
123f0 73 74 2d 67 65 74 2d 69 73 2d 74 6f 70 6c 65 76 st-get-is-toplev
12400 65 6c 20 74 65 73 74 29 0a 09 09 09 09 09 09 09 el test)........
12410 20 20 20 20 20 20 20 28 3e 20 28 72 6d 74 3a 74 (> (rmt:t
12420 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d est-toplevel-num
12430 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 -items run-id te
12440 73 74 2d 6e 61 6d 65 29 20 30 29 29 29 29 0a 09 st-name) 0))))..
12450 09 09 20 20 20 20 20 28 63 61 73 65 20 61 63 74 .. (case act
12460 69 6f 6e 0a 09 09 09 20 20 20 20 20 20 20 28 28 ion.... ((
12470 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 09 remove-runs)....
12480 09 3b 3b 20 69 66 20 74 68 65 20 74 65 73 74 20 .;; if the test
12490 69 73 20 61 20 74 6f 70 6c 65 76 65 6c 2d 77 69 is a toplevel-wi
124a0 74 68 2d 63 68 69 6c 64 72 65 6e 20 69 73 73 75 th-children issu
124b0 65 20 61 6e 20 65 72 72 6f 72 20 61 6e 64 20 64 e an error and d
124c0 6f 20 6e 6f 74 20 72 65 6d 6f 76 65 0a 09 09 09 o not remove....
124d0 09 28 69 66 20 74 6f 70 6c 65 76 65 6c 2d 77 69 .(if toplevel-wi
124e0 74 68 2d 63 68 69 6c 64 72 65 6e 0a 09 09 09 09 th-children.....
124f0 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 (begin.....
12500 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
12510 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 73 6b t 0 "WARNING: sk
12520 69 70 70 69 6e 67 20 72 65 6d 6f 76 61 6c 20 6f ipping removal o
12530 66 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e 20 22 f " test-fulln "
12540 20 77 69 74 68 20 72 75 6e 2d 69 64 20 22 20 72 with run-id " r
12550 75 6e 2d 69 64 20 22 20 61 73 20 69 74 20 68 61 un-id " as it ha
12560 73 20 73 75 62 20 74 65 73 74 73 22 29 0a 09 09 s sub tests")...
12570 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
12580 62 6c 65 2d 73 65 74 21 20 74 6f 70 6c 65 76 65 ble-set! topleve
12590 6c 2d 72 65 74 72 69 65 73 20 74 65 73 74 2d 66 l-retries test-f
125a0 75 6c 6c 6e 20 28 2b 20 28 68 61 73 68 2d 74 61 ulln (+ (hash-ta
125b0 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
125c0 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 73 toplevel-retries
125d0 20 74 65 73 74 2d 66 75 6c 6c 6e 20 30 29 20 31 test-fulln 0) 1
125e0 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 ))..... (if
125f0 20 28 3e 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (> (hash-table-
12600 72 65 66 20 74 6f 70 6c 65 76 65 6c 2d 72 65 74 ref toplevel-ret
12610 72 69 65 73 20 74 65 73 74 2d 66 75 6c 6c 6e 29 ries test-fulln)
12620 20 33 29 0a 09 09 09 09 09 20 20 28 69 66 20 28 3)...... (if (
12630 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
12640 0a 09 09 09 09 09 20 20 20 20 20 20 28 6c 6f 6f ...... (loo
12650 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
12660 74 61 6c 29 29 29 20 3b 3b 20 6e 6f 20 65 6c 73 tal))) ;; no els
12670 65 20 63 6c 61 75 73 65 20 2d 20 64 72 6f 70 20 e clause - drop
12680 69 74 20 69 66 20 6e 6f 20 6d 6f 72 65 20 69 6e it if no more in
12690 20 71 75 65 75 65 20 61 6e 64 20 3e 20 33 20 74 queue and > 3 t
126a0 72 69 65 73 0a 09 09 09 09 09 20 20 28 6c 65 74 ries...... (let
126b0 20 28 28 6e 65 77 74 61 6c 20 28 61 70 70 65 6e ((newtal (appen
126c0 64 20 74 61 6c 20 28 6c 69 73 74 20 74 65 73 74 d tal (list test
126d0 29 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 6c ))))...... (l
126e0 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
126f0 28 63 64 72 20 6e 65 77 74 61 6c 29 29 29 29 29 (cdr newtal)))))
12700 20 3b 3b 20 6c 6f 6f 70 20 77 69 74 68 20 74 65 ;; loop with te
12710 73 74 20 73 74 69 6c 6c 20 69 6e 20 71 75 65 75 st still in queu
12720 65 0a 09 09 09 09 20 20 20 20 28 62 65 67 69 6e e..... (begin
12730 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
12740 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
12750 74 65 73 74 3a 20 22 20 74 65 73 74 2d 6e 61 6d test: " test-nam
12760 65 20 22 20 69 74 65 73 74 2d 73 74 61 74 65 3a e " itest-state:
12770 20 22 20 74 65 73 74 2d 73 74 61 74 65 29 0a 09 " test-state)..
12780 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6d 65 ... (if (me
12790 6d 62 65 72 20 74 65 73 74 2d 73 74 61 74 65 20 mber test-state
127a0 28 6c 69 73 74 20 22 52 55 4e 4e 49 4e 47 22 20 (list "RUNNING"
127b0 22 4c 41 55 4e 43 48 45 44 22 20 22 52 45 4d 4f "LAUNCHED" "REMO
127c0 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 4b 49 TEHOSTSTART" "KI
127d0 4c 4c 52 45 51 22 29 29 0a 09 09 09 09 09 20 20 LLREQ"))......
127e0 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 (begin......
127f0 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
12800 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
12810 20 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 test-retry-time
12820 20 74 65 73 74 2d 66 75 6c 6c 6e 20 23 66 29 29 test-fulln #f))
12830 0a 09 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 .......(begin...
12840 09 09 09 09 20 20 3b 3b 20 77 61 6e 74 20 74 6f .... ;; want to
12850 20 73 65 74 20 74 6f 20 52 45 4d 4f 56 49 4e 47 set to REMOVING
12860 20 42 55 54 20 43 41 4e 4e 4f 54 20 64 6f 20 69 BUT CANNOT do i
12870 74 20 68 65 72 65 3f 0a 09 09 09 09 09 09 20 20 t here?.......
12880 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
12890 20 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 test-retry-time
128a0 20 74 65 73 74 2d 66 75 6c 6c 6e 20 28 63 75 72 test-fulln (cur
128b0 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 rent-seconds))))
128c0 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 28 3e ...... (if (>
128d0 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
128e0 6f 6e 64 73 29 28 68 61 73 68 2d 74 61 62 6c 65 onds)(hash-table
128f0 2d 72 65 66 20 74 65 73 74 2d 72 65 74 72 79 2d -ref test-retry-
12900 74 69 6d 65 20 74 65 73 74 2d 66 75 6c 6c 6e 29 time test-fulln)
12910 29 20 61 6c 6c 6f 77 2d 72 75 6e 2d 74 69 6d 65 ) allow-run-time
12920 29 0a 09 09 09 09 09 09 3b 3b 20 54 68 69 73 20 ).......;; This
12930 74 65 73 74 20 69 73 20 6e 6f 74 20 69 6e 20 61 test is not in a
12940 20 63 6f 72 72 65 63 74 20 73 74 61 74 65 20 66 correct state f
12950 6f 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 2e 20 or cleaning up.
12960 4c 65 74 27 73 20 74 72 79 20 73 6f 6d 65 20 67 Let's try some g
12970 72 61 63 65 66 75 6c 20 73 68 75 74 64 6f 77 6e raceful shutdown
12980 20 73 74 65 70 73 20 66 69 72 73 74 0a 09 09 09 steps first....
12990 09 09 09 3b 3b 20 53 65 74 20 74 68 65 20 74 65 ...;; Set the te
129a0 73 74 20 74 6f 20 22 4b 49 4c 4c 52 45 51 22 20 st to "KILLREQ"
129b0 61 6e 64 20 77 61 69 74 20 66 69 76 65 20 73 65 and wait five se
129c0 63 6f 6e 64 73 20 74 68 65 6e 20 74 72 79 20 61 conds then try a
129d0 67 61 69 6e 2e 20 52 65 70 65 61 74 20 75 70 20 gain. Repeat up
129e0 74 6f 20 66 69 76 65 20 74 69 6d 65 73 20 74 68 to five times th
129f0 65 6e 20 67 69 76 65 0a 09 09 09 09 09 09 3b 3b en give.......;;
12a00 20 75 70 20 61 6e 64 20 62 6c 6f 77 20 69 74 20 up and blow it
12a10 61 77 61 79 2e 0a 09 09 09 09 09 09 28 62 65 67 away........(beg
12a20 69 6e 0a 09 09 09 09 09 09 20 20 28 64 65 62 75 in....... (debu
12a30 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
12a40 4e 47 3a 20 63 6f 75 6c 64 20 6e 6f 74 20 67 72 NG: could not gr
12a50 61 63 65 66 75 6c 6c 79 20 72 65 6d 6f 76 65 20 acefully remove
12a60 74 65 73 74 20 22 20 74 65 73 74 2d 66 75 6c 6c test " test-full
12a70 6e 20 22 2c 20 74 72 69 65 64 20 74 6f 20 6b 69 n ", tried to ki
12a80 6c 6c 20 69 74 20 74 6f 20 6e 6f 20 61 76 61 69 ll it to no avai
12a90 6c 2e 20 46 6f 72 63 69 6e 67 20 73 74 61 74 65 l. Forcing state
12aa0 20 74 6f 20 46 41 49 4c 45 44 4b 49 4c 4c 20 61 to FAILEDKILL a
12ab0 6e 64 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a nd continuing").
12ac0 09 09 09 09 09 20 20 20 20 28 6d 74 3a 74 65 73 ..... (mt:tes
12ad0 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
12ae0 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
12af0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
12b00 74 65 73 74 29 20 22 46 41 49 4c 45 44 4b 49 4c test) "FAILEDKIL
12b10 4c 22 20 22 6e 2f 61 22 20 23 66 29 0a 09 09 09 L" "n/a" #f)....
12b20 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
12b30 65 70 21 20 31 29 29 0a 09 09 09 09 09 09 28 62 ep! 1)).......(b
12b40 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 28 6d egin...... (m
12b50 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
12b60 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
12b70 6e 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 n-id (db:test-ge
12b80 74 2d 69 64 20 74 65 73 74 29 20 22 4b 49 4c 4c t-id test) "KILL
12b90 52 45 51 22 20 22 6e 2f 61 22 20 23 66 29 0a 09 REQ" "n/a" #f)..
12ba0 09 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 ..... (thread-s
12bb0 6c 65 65 70 21 20 31 29 29 29 0a 09 09 09 09 09 leep! 1)))......
12bc0 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
12bd0 73 20 69 73 20 73 75 62 6f 70 74 69 6d 61 6c 20 s is suboptimal
12be0 61 73 20 74 68 65 20 74 65 73 74 64 61 74 61 20 as the testdata
12bf0 77 69 6c 6c 20 62 65 20 75 73 65 64 20 6c 61 74 will be used lat
12c00 65 72 20 61 6e 64 20 74 68 65 20 73 74 61 74 65 er and the state
12c10 2f 73 74 61 74 75 73 20 6d 61 79 20 68 61 76 65 /status may have
12c20 20 63 68 61 6e 67 65 64 20 2e 2e 2e 0a 09 09 09 changed .......
12c30 09 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f .. (if (null?
12c40 20 74 61 6c 29 0a 09 09 09 09 09 09 28 6c 6f 6f tal).......(loo
12c50 70 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 20 74 p new-test-dat t
12c60 61 6c 29 0a 09 09 09 09 09 09 28 6c 6f 6f 70 20 al).......(loop
12c70 28 63 61 72 20 74 61 6c 29 28 61 70 70 65 6e 64 (car tal)(append
12c80 20 74 61 6c 20 28 6c 69 73 74 20 6e 65 77 2d 74 tal (list new-t
12c90 65 73 74 2d 64 61 74 29 29 29 29 29 0a 09 09 09 est-dat)))))....
12ca0 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 .. (begin......
12cb0 20 20 20 20 28 72 75 6e 73 3a 72 65 6d 6f 76 65 (runs:remove
12cc0 2d 74 65 73 74 2d 64 69 72 65 63 74 6f 72 79 20 -test-directory
12cd0 6e 65 77 2d 74 65 73 74 2d 64 61 74 20 6d 6f 64 new-test-dat mod
12ce0 65 29 20 3b 3b 20 27 72 65 6d 6f 76 65 2d 61 6c e) ;; 'remove-al
12cf0 6c 29 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 l)...... (if
12d00 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
12d10 29 0a 09 09 09 09 09 09 28 6c 6f 6f 70 20 28 63 ).......(loop (c
12d20 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
12d30 29 29 29 29 29 29 29 0a 09 09 09 20 20 20 20 20 )))))))....
12d40 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 ((set-state-st
12d50 61 74 75 73 29 0a 09 09 09 09 28 64 65 62 75 67 atus).....(debug
12d60 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e :print-info 2 "n
12d70 65 77 20 73 74 61 74 65 20 22 20 28 63 61 72 20 ew state " (car
12d80 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c state-status) ",
12d90 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 63 new status " (c
12da0 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 adr state-status
12db0 29 29 0a 09 09 09 09 28 6d 74 3a 74 65 73 74 2d )).....(mt:test-
12dc0 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
12dd0 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 64 -by-id run-id (d
12de0 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
12df0 73 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 st) (car state-s
12e00 74 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 tatus)(cadr stat
12e10 65 2d 73 74 61 74 75 73 29 20 23 66 29 0a 09 09 e-status) #f)...
12e20 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ..(if (not (null
12e30 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 20 20 20 ? tal)).....
12e40 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
12e50 63 64 72 20 74 61 6c 29 29 29 29 0a 09 09 09 20 cdr tal))))....
12e60 20 20 20 20 20 20 28 28 72 75 6e 2d 77 61 69 74 ((run-wait
12e70 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
12e80 6e 74 2d 69 6e 66 6f 20 32 20 22 73 74 69 6c 6c nt-info 2 "still
12e90 20 77 61 69 74 69 6e 67 2c 20 22 20 28 6c 65 6e waiting, " (len
12ea0 67 74 68 20 74 65 73 74 73 29 20 22 20 74 65 73 gth tests) " tes
12eb0 74 73 20 73 74 69 6c 6c 20 72 75 6e 6e 69 6e 67 ts still running
12ec0 22 29 0a 09 09 09 09 28 74 68 72 65 61 64 2d 73 ").....(thread-s
12ed0 6c 65 65 70 21 20 31 30 29 0a 09 09 09 09 28 6c leep! 10).....(l
12ee0 65 74 20 28 28 6e 65 77 2d 74 65 73 74 73 20 28 et ((new-tests (
12ef0 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 72 proc-get-tests r
12f00 75 6e 2d 69 64 29 29 29 0a 09 09 09 09 20 20 28 un-id)))..... (
12f10 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 2d 74 65 if (null? new-te
12f20 73 74 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 sts)..... (
12f30 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
12f40 20 31 20 22 52 75 6e 20 63 6f 6d 70 6c 65 74 65 1 "Run complete
12f50 64 20 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 7a d according to z
12f60 65 72 6f 20 74 65 73 74 73 20 6d 61 74 63 68 69 ero tests matchi
12f70 6e 67 20 70 72 6f 76 69 64 65 64 20 63 72 69 74 ng provided crit
12f80 65 72 69 61 2e 22 29 0a 09 09 09 09 20 20 20 20 eria.").....
12f90 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
12fa0 2d 74 65 73 74 73 29 28 63 64 72 20 6e 65 77 2d -tests)(cdr new-
12fb0 74 65 73 74 73 29 29 29 29 29 0a 09 09 09 20 20 tests)))))....
12fc0 20 20 20 20 20 28 28 61 72 63 68 69 76 65 29 0a ((archive).
12fd0 09 09 09 09 28 69 66 20 28 61 6e 64 20 72 75 6e ....(if (and run
12fe0 2d 64 69 72 20 28 6e 6f 74 20 74 6f 70 6c 65 76 -dir (not toplev
12ff0 65 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 65 6e el-with-children
13000 29 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 ))..... (let
13010 28 28 64 64 69 72 20 28 63 6f 6e 63 20 72 75 6e ((ddir (conc run
13020 2d 64 69 72 20 22 2f 22 29 29 29 0a 09 09 09 09 -dir "/"))).....
13030 20 20 20 20 20 20 28 63 61 73 65 20 28 73 74 72 (case (str
13040 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 61 72 67 ing->symbol (arg
13050 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 63 68 s:get-arg "-arch
13060 69 76 65 22 29 29 0a 09 09 09 09 09 28 28 73 61 ive"))......((sa
13070 76 65 20 73 61 76 65 2d 72 65 6d 6f 76 65 20 6b ve save-remove k
13080 65 65 70 2d 68 74 6d 6c 29 0a 09 09 09 09 09 20 eep-html)......
13090 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
130a0 3f 20 64 64 69 72 29 0a 09 09 09 09 09 20 20 20 ? ddir)......
130b0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
130c0 6e 66 6f 20 30 20 22 45 73 74 69 6d 61 74 69 6e nfo 0 "Estimatin
130d0 67 20 64 69 73 6b 20 73 70 61 63 65 20 75 73 61 g disk space usa
130e0 67 65 20 66 6f 72 20 22 20 74 65 73 74 2d 66 75 ge for " test-fu
130f0 6c 6c 6e 20 22 3a 20 22 20 28 63 6f 6d 6d 6f 6e lln ": " (common
13100 3a 67 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d :get-disk-space-
13110 75 73 65 64 20 64 64 69 72 29 29 29 29 29 29 29 used ddir)))))))
13120 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e .....(if (not (n
13130 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 ull? tal)).....
13140 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
13150 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a 09 l)(cdr tal))))..
13160 09 09 20 20 20 20 20 20 20 29 29 29 0a 09 09 20 .. )))...
13170 20 20 20 20 20 20 29 0a 09 09 20 20 20 20 20 28 )... (
13180 69 66 20 77 6f 72 6b 65 72 2d 74 68 72 65 61 64 if worker-thread
13190 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 77 (thread-join! w
131a0 6f 72 6b 65 72 2d 74 68 72 65 61 64 29 29 29 29 orker-thread))))
131b0 29 29 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 65 )).. ;; remove
131c0 20 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 6f the run if zero
131d0 20 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 20 tests remain..
131e0 20 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 6f (if (eq? actio
131f0 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a n 'remove-runs).
13200 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 . (let ((r
13210 65 6d 74 65 73 74 73 20 28 6d 74 3a 67 65 74 2d emtests (mt:get-
13220 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 28 64 tests-for-run (d
13230 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
13240 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
13250 20 22 69 64 22 29 20 23 66 20 27 28 22 44 45 4c "id") #f '("DEL
13260 45 54 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 ETED") '("n/a")
13270 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 not-in: #t)))...
13280 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 (if (null? remt
13290 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 ests) ;; no more
132a0 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 tests remaining
132b0 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
132c0 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d dparts (string-
132d0 73 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 split lasttpath
132e0 22 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 "/")).... (ru
132f0 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 npath (conc "/"
13300 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
13310 72 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 rse .......(take
13320 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 dparts (- (leng
13330 74 68 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 th dparts) 1))..
13340 09 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 ....."/"))))...
13350 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
13360 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 nt 1 "Removing r
13370 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
13380 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
13390 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
133a0 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 der "runname") "
133b0 20 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 and related rec
133c0 6f 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 ord")... (
133d0 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 72 rmt:delete-run r
133e0 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 un-id)...
133f0 28 72 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d (rmt:delete-old-
13400 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 deleted-test-rec
13410 6f 72 64 73 29 0a 09 09 20 20 20 20 20 20 20 3b ords)... ;
13420 3b 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 22 ; (rmt:set-var "
13430 44 45 4c 45 54 45 44 5f 54 45 53 54 53 22 20 28 DELETED_TESTS" (
13440 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
13450 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 6e 65 )... ;; ne
13460 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 ed to figure out
13470 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 the path to the
13480 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 6d run dir and rem
13490 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 0a ove it if empty.
134a0 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 .. ;; (
134b0 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 if (null? (glob
134c0 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 22 2f (conc runpath "/
134d0 2a 22 29 29 29 0a 09 09 20 20 20 20 20 20 20 3b *")))... ;
134e0 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a ; (begin.
134f0 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 64 .. ;; . (d
13500 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 ebug:print 1 "Re
13510 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 20 22 moving run dir "
13520 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 20 20 runpath)...
13530 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 ;; . (system
13540 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 (conc "rmdir -p
13550 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 09 " runpath))))...
13560 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 20 29 ))))).. )
13570 29 0a 20 20 20 20 20 72 75 6e 73 29 0a 20 20 20 ). runs).
13580 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e ;; (sqlite3:fin
13590 61 6c 69 7a 65 21 20 28 64 62 3a 64 65 6c 61 79 alize! (db:delay
135a0 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 -if-busy tdbdat)
135b0 29 0a 20 20 20 20 29 0a 20 20 23 74 29 0a 0a 28 ). ). #t)..(
135c0 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 6d define (runs:rem
135d0 6f 76 65 2d 74 65 73 74 2d 64 69 72 65 63 74 6f ove-test-directo
135e0 72 79 20 74 65 73 74 20 6d 6f 64 65 29 20 3b 3b ry test mode) ;;
135f0 20 72 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c remove-data-onl
13600 79 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e y). (let* ((run
13610 2d 64 69 72 20 20 20 20 20 20 20 28 64 62 3a 74 -dir (db:t
13620 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 est-get-rundir t
13630 65 73 74 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 est)) ;; run
13640 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 20 dir is from the
13650 6c 69 6e 6b 20 74 72 65 65 0a 09 20 28 72 65 61 link tree.. (rea
13660 6c 2d 64 69 72 20 20 20 20 20 20 28 69 66 20 28 l-dir (if (
13670 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
13680 2d 64 69 72 29 0a 09 09 09 20 20 20 20 28 72 65 -dir).... (re
13690 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 solve-pathname r
136a0 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 23 un-dir).... #
136b0 66 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 6d f))). (case m
136c0 6f 64 65 0a 20 20 20 20 20 20 28 28 72 65 6d 6f ode. ((remo
136d0 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 29 28 6d 74 ve-data-only)(mt
136e0 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
136f0 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 status-by-id (db
13700 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 :test-get-run_id
13710 20 74 65 73 74 29 28 64 62 3a 74 65 73 74 2d 67 test)(db:test-g
13720 65 74 2d 69 64 20 74 65 73 74 29 20 22 43 4c 45 et-id test) "CLE
13730 41 4e 49 4e 47 22 20 22 4c 4f 43 4b 45 44 22 20 ANING" "LOCKED"
13740 23 66 29 29 0a 20 20 20 20 20 20 28 28 72 65 6d #f)). ((rem
13750 6f 76 65 2d 61 6c 6c 29 20 20 20 20 20 20 28 6d ove-all) (m
13760 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
13770 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 -status-by-id (d
13780 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 b:test-get-run_i
13790 64 20 74 65 73 74 29 28 64 62 3a 74 65 73 74 2d d test)(db:test-
137a0 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 52 45 get-id test) "RE
137b0 4d 4f 56 49 4e 47 22 20 22 4c 4f 43 4b 45 44 22 MOVING" "LOCKED"
137c0 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 61 72 #f)). ((ar
137d0 63 68 69 76 65 2d 72 65 6d 6f 76 65 29 20 20 28 chive-remove) (
137e0 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
137f0 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 e-status-by-id (
13800 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f db:test-get-run_
13810 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 73 74 id test)(db:test
13820 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 41 -get-id test) "A
13830 52 43 48 49 56 45 5f 52 45 4d 4f 56 49 4e 47 22 RCHIVE_REMOVING"
13840 20 23 66 20 23 66 29 29 29 0a 20 20 20 20 28 64 #f #f))). (d
13850 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
13860 31 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 1 "Attempting to
13870 20 72 65 6d 6f 76 65 20 22 20 28 69 66 20 72 65 remove " (if re
13880 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 64 al-dir (conc " d
13890 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 ir " real-dir "
138a0 61 6e 64 20 22 29 20 22 22 29 20 22 20 6c 69 6e and ") "") " lin
138b0 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 20 20 20 k " run-dir).
138c0 20 28 69 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 (if (and real-d
138d0 69 72 20 0a 09 20 20 20 20 20 28 3e 20 28 73 74 ir .. (> (st
138e0 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 6c ring-length real
138f0 2d 64 69 72 29 20 35 29 0a 09 20 20 20 20 20 28 -dir) 5).. (
13900 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 file-exists? rea
13910 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 68 l-dir)) ;; bad h
13920 65 75 72 69 73 74 69 63 20 62 75 74 20 73 68 6f euristic but sho
13930 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 uld prevent /tmp
13940 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 28 62 65 /home etc...(be
13950 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 gin ;; let* ((re
13960 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d alpath (resolve-
13970 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 pathname run-dir
13980 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 ))).. (debug:pr
13990 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 int-info 1 "Recu
139a0 72 73 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 rsively removing
139b0 20 22 20 72 65 61 6c 2d 64 69 72 29 0a 09 20 20 " real-dir)..
139c0 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
139d0 3f 20 72 65 61 6c 2d 64 69 72 29 0a 09 20 20 20 ? real-dir)..
139e0 20 20 20 28 72 75 6e 73 3a 73 61 66 65 2d 64 65 (runs:safe-de
139f0 6c 65 74 65 2d 74 65 73 74 2d 64 69 72 20 72 65 lete-test-dir re
13a00 61 6c 2d 64 69 72 29 0a 09 20 20 20 20 20 20 28 al-dir).. (
13a10 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
13a20 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 64 69 72 ARNING: test dir
13a30 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 70 " real-dir " ap
13a40 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 69 pears to not exi
13a50 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 72 65 61 st or is not rea
13a60 64 61 62 6c 65 22 29 29 29 0a 09 28 69 66 20 72 dable")))..(if r
13a70 65 61 6c 2d 64 69 72 20 0a 09 20 20 20 20 28 64 eal-dir .. (d
13a80 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
13a90 52 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 RNING: directory
13aa0 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f " real-dir " do
13ab0 65 73 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 es not exist")..
13ac0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
13ad0 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 0 "WARNING: no
13ae0 72 65 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 real directory c
13af0 6f 72 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 orrosponding to
13b00 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 link " run-dir "
13b10 2c 20 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 , nothing done")
13b20 29 29 0a 20 20 20 20 28 69 66 20 28 73 79 6d 62 )). (if (symb
13b30 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 olic-link? run-d
13b40 69 72 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 ir)..(begin.. (
13b50 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
13b60 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 1 "Removing sym
13b70 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a link " run-dir).
13b80 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
13b90 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 tions.. exn..
13ba0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
13bb0 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
13bc0 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 to remove symli
13bd0 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 nk " run-dir ((c
13be0 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
13bf0 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
13c00 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 'message) exn) "
13c10 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 , attempting to
13c20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 20 20 20 28 continue").. (
13c30 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d delete-file run-
13c40 64 69 72 29 29 29 0a 09 28 69 66 20 28 64 69 72 dir)))..(if (dir
13c50 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 29 ectory? run-dir)
13c60 0a 09 20 20 20 20 28 69 66 20 28 3e 20 28 64 69 .. (if (> (di
13c70 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 rectory-fold (la
13c80 6d 62 64 61 20 28 66 20 78 29 28 2b 20 31 20 78 mbda (f x)(+ 1 x
13c90 29 29 20 30 20 72 75 6e 2d 64 69 72 29 20 30 29 )) 0 run-dir) 0)
13ca0 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
13cb0 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 0 "WARNING: refu
13cc0 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 sing to remove "
13cd0 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 run-dir " as it
13ce0 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a is not empty").
13cf0 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ..(handle-except
13d00 69 6f 6e 73 0a 09 09 20 65 78 6e 0a 09 09 20 28 ions... exn... (
13d10 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
13d20 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f RROR: Failed to
13d30 20 72 65 6d 6f 76 65 20 64 69 72 65 63 74 6f 72 remove director
13d40 79 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f y " run-dir ((co
13d50 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
13d60 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
13d70 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c message) exn) ",
13d80 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
13d90 6f 6e 74 69 6e 75 65 22 29 0a 09 09 20 28 64 65 ontinue")... (de
13da0 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 lete-directory r
13db0 75 6e 2d 64 69 72 29 29 29 0a 09 20 20 20 20 28 un-dir))).. (
13dc0 69 66 20 28 61 6e 64 20 72 75 6e 2d 64 69 72 0a if (and run-dir.
13dd0 09 09 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d .. (not (mem
13de0 62 65 72 20 72 75 6e 2d 64 69 72 20 28 6c 69 73 ber run-dir (lis
13df0 74 20 22 6e 2f 61 22 20 22 2f 74 6d 70 2f 62 61 t "n/a" "/tmp/ba
13e00 64 6e 61 6d 65 22 29 29 29 29 0a 09 09 28 64 65 dname"))))...(de
13e10 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
13e20 4e 49 4e 47 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 NING: not removi
13e30 6e 67 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 ng " run-dir " a
13e40 73 20 69 74 20 65 69 74 68 65 72 20 64 6f 65 73 s it either does
13e50 6e 27 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 n't exist or is
13e60 6e 6f 74 20 61 20 73 79 6d 6c 69 6e 6b 22 29 0a not a symlink").
13e70 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
13e80 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 "NOTE: the run
13e90 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 dir for this tes
13ea0 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 t is undefined.
13eb0 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c Test may have al
13ec0 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 ready been delet
13ed0 65 64 2e 22 29 29 0a 09 20 20 20 20 29 29 0a 20 ed.")).. )).
13ee0 20 20 20 3b 3b 20 4f 6e 6c 79 20 64 65 6c 65 74 ;; Only delet
13ef0 65 20 74 68 65 20 72 65 63 6f 72 64 73 20 2a 61 e the records *a
13f00 66 74 65 72 2a 20 72 65 6d 6f 76 69 6e 67 20 74 fter* removing t
13f10 68 65 20 64 69 72 65 63 74 6f 72 79 2e 20 49 66 he directory. If
13f20 20 74 68 69 6e 67 73 20 66 61 69 6c 20 77 65 20 things fail we
13f30 68 61 76 65 20 61 20 72 65 63 6f 72 64 20 0a 20 have a record .
13f40 20 20 20 28 63 61 73 65 20 6d 6f 64 65 0a 20 20 (case mode.
13f50 20 20 20 20 28 28 72 65 6d 6f 76 65 2d 64 61 74 ((remove-dat
13f60 61 2d 6f 6e 6c 79 29 28 6d 74 3a 74 65 73 74 2d a-only)(mt:test-
13f70 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
13f80 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 2d -by-id (db:test-
13f90 67 65 74 2d 72 75 6e 5f 69 64 20 74 65 73 74 29 get-run_id test)
13fa0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
13fb0 74 65 73 74 29 20 22 4e 4f 54 5f 53 54 41 52 54 test) "NOT_START
13fc0 45 44 22 20 22 6e 2f 61 22 20 23 66 29 29 0a 20 ED" "n/a" #f)).
13fd0 20 20 20 20 20 28 28 61 72 63 68 69 76 65 2d 72 ((archive-r
13fe0 65 6d 6f 76 65 29 20 20 28 6d 74 3a 74 65 73 74 emove) (mt:test
13ff0 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
14000 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 s-by-id (db:test
14010 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 65 73 74 -get-run_id test
14020 29 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 )(db:test-get-id
14030 20 74 65 73 74 29 20 22 41 52 43 48 49 56 45 44 test) "ARCHIVED
14040 22 20 23 66 20 23 66 29 29 0a 20 20 20 20 20 20 " #f #f)).
14050 28 65 6c 73 65 20 28 72 6d 74 3a 64 65 6c 65 74 (else (rmt:delet
14060 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 28 e-test-records (
14070 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f db:test-get-run_
14080 69 64 20 74 65 73 74 29 20 28 64 62 3a 74 65 73 id test) (db:tes
14090 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 29 t-get-id test)))
140a0 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
140b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
140f0 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 Routines for ma
14100 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a nipulating runs.
14110 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
14120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14150 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e ========..;; Sin
14160 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f ce many calls to
14170 20 61 20 72 75 6e 20 72 65 71 75 69 72 65 20 70 a run require p
14180 72 65 74 74 79 20 6d 75 63 68 20 74 68 65 20 73 retty much the s
14190 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 ame setup .;; th
141a0 69 73 20 77 72 61 70 70 65 72 20 69 73 20 75 73 is wrapper is us
141b0 65 64 20 74 6f 20 72 65 64 75 63 65 20 74 68 65 ed to reduce the
141c0 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 replication of
141d0 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 67 65 code.(define (ge
141e0 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 neral-run-call s
141f0 77 69 74 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e witchname action
14200 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 20 28 6c -desc proc). (l
14210 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 6f 72 et ((runname (or
14220 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
14230 2d 72 75 6e 6e 61 6d 65 22 29 28 61 72 67 73 3a -runname")(args:
14240 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
14250 65 22 29 29 29 0a 09 28 74 61 72 67 65 74 20 20 e")))..(target
14260 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
14270 2d 74 61 72 67 65 74 29 29 29 0a 20 20 20 20 28 -target))). (
14280 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 cond. ((not
14290 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 28 64 target). (d
142a0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
142b0 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 ROR: Missing req
142c0 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 uired parameter
142d0 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 for " switchname
142e0 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 ", you must spe
142f0 63 69 66 79 20 74 68 65 20 74 61 72 67 65 74 20 cify the target
14300 77 69 74 68 20 2d 74 61 72 67 65 74 22 29 0a 20 with -target").
14310 20 20 20 20 20 28 65 78 69 74 20 33 29 29 0a 20 (exit 3)).
14320 20 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d ((not runnam
14330 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a e). (debug:
14340 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
14350 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 Missing required
14360 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 parameter for "
14370 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 switchname ", y
14380 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 ou must specify
14390 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 the run name wit
143a0 68 20 2d 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 h -runname runna
143b0 6d 65 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 me"). (exit
143c0 20 33 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 3)). (else.
143d0 20 20 20 20 20 20 28 6c 65 74 20 28 3b 3b 20 28 (let (;; (
143e0 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b db #f).. (k
143f0 65 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 6c eys #f))..(if (l
14400 61 75 6e 63 68 3a 73 65 74 75 70 2d 66 6f 72 2d aunch:setup-for-
14410 72 75 6e 29 0a 09 20 20 20 20 28 6c 61 75 6e 63 run).. (launc
14420 68 3a 63 61 63 68 65 2d 63 6f 6e 66 69 67 29 0a h:cache-config).
14430 09 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 . (begin ..
14440 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
14450 20 30 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 0 "Failed to se
14460 74 75 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 tup, exiting")..
14470 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
14480 0a 09 28 73 65 74 21 20 6b 65 79 73 20 28 6b 65 ..(set! keys (ke
14490 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 ys:config-get-fi
144a0 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a elds *configdat*
144b0 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 ))..;; have enou
144c0 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 gh to process -t
144d0 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 arget or -reqtar
144e0 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 g here..(if (arg
144f0 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
14500 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a arg").. (let*
14510 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 ((runconfigf (c
14520 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 onc *toppath* "
14530 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
14540 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 ig")) ;; DO NOT
14550 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 EVALUATE ALL ...
14560 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 (runconfig (
14570 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 read-config runc
14580 6f 6e 66 69 67 66 20 23 66 20 23 74 20 65 6e 76 onfigf #f #t env
14590 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 iron-patt: #f)))
145a0 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 .. (if (has
145b0 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
145c0 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 ult runconfig (a
145d0 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
145e0 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 qtarg") #f)...
145f0 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 (keys:target-set
14600 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 -args keys (args
14610 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
14620 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 rg") args:arg-ha
14630 73 68 29 0a 09 09 20 20 20 20 0a 09 09 20 20 28 sh)... ... (
14640 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 begin... (deb
14650 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
14660 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d R: [" (args:get-
14670 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
14680 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 "] not found in
14690 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 " runconfigf)...
146a0 20 20 20 20 3b 3b 20 28 69 66 20 64 62 20 28 73 ;; (if db (s
146b0 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
146c0 20 64 62 29 29 0a 09 09 20 20 20 20 28 65 78 69 db))... (exi
146d0 74 20 31 29 0a 09 09 20 20 20 20 29 29 29 0a 09 t 1)... )))..
146e0 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
146f0 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
14700 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d ...(keys:target-
14710 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 set-args keys (a
14720 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
14730 72 67 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 rget" args:arg-h
14740 61 73 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 ash) args:arg-ha
14750 73 68 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 sh)))..(if (not
14760 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f (car *configinfo
14770 2a 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a *)).. (begin.
14780 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
14790 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 int 0 "ERROR: At
147a0 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 tempted to " act
147b0 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 ion-desc " but r
147c0 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 un area config f
147d0 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a ile not found").
147e0 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 . (exit 1))
147f0 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 .. ;; Extract
14800 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 out stuff neede
14810 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e d in most or man
14820 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 y calls.. ;;
14830 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 here then call p
14840 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 roc.. (let* (
14850 28 6b 65 79 76 61 6c 73 20 20 20 20 28 6b 65 79 (keyvals (key
14860 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c s:target->keyval
14870 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 29 0a keys target))).
14880 09 20 20 20 20 20 20 28 70 72 6f 63 20 74 61 72 . (proc tar
14890 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 79 73 get runname keys
148a0 20 6b 65 79 76 61 6c 73 29 29 29 0a 09 3b 3b 20 keyvals)))..;;
148b0 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
148c0 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
148d0 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 (set! *didsometh
148e0 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b ing* #t))))))..;
148f0 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
14900 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14910 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14920 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14930 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b 2f =======.;; Lock/
14940 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d unlock runs.;;==
14950 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14960 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14970 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14980 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14990 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
149a0 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 uns:handle-locki
149b0 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 ng target keys r
149c0 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f unname lock unlo
149d0 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a ck user). (let*
149e0 20 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a ((db #f).
149f0 09 20 28 72 75 6e 64 61 74 20 20 20 28 6d 74 3a . (rundat (mt:
14a00 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
14a10 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 74 61 keys runname ta
14a20 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 72 rget)).. (header
14a30 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
14a40 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e undat 0)).. (run
14a50 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 s (vector-re
14a60 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 20 f rundat 1))).
14a70 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
14a80 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 74 bda (run)...(let
14a90 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 ((run-id (db:ge
14aa0 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
14ab0 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 r run header "id
14ac0 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 6f 72 ")))... (if (or
14ad0 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 20 lock.... (and
14ae0 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 20 unlock....
14af0 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 72 (begin..... (pr
14b00 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 61 6c int "Do you real
14b10 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f 63 ly wish to unloc
14b20 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 k run " run-id "
14b30 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 09 ?\n y/n: ")...
14b40 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 20 28 .. (equal? "y" (
14b50 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 read-line)))))..
14b60 09 20 20 20 20 20 20 28 72 6d 74 3a 6c 6f 63 6b . (rmt:lock
14b70 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d /unlock-run run-
14b80 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 id lock unlock u
14b90 73 65 72 29 0a 09 09 20 20 20 20 20 20 28 64 65 ser)... (de
14ba0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
14bb0 20 22 53 6b 69 70 70 69 6e 67 20 6c 6f 63 6b 2f "Skipping lock/
14bc0 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 6e 2d unlock on " run-
14bd0 69 64 29 29 29 29 0a 09 20 20 20 20 20 20 72 75 id)))).. ru
14be0 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ns))).;;========
14bf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
14c30 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b ; Rollup runs.;;
14c40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c80 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 61 74 ======..;; Updat
14c90 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 e the test_meta
14ca0 74 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 74 table for this t
14cb0 65 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e est.(define (run
14cc0 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 s:update-test_me
14cd0 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ta test-name tes
14ce0 74 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 t-conf). (let (
14cf0 28 63 75 72 72 72 65 63 6f 72 64 20 28 72 6d 74 (currrecord (rmt
14d00 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 :testmeta-get-re
14d10 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 cord test-name))
14d20 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 ). (if (not c
14d30 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 urrrecord)..(beg
14d40 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 in.. (set! curr
14d50 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 record (make-vec
14d60 74 6f 72 20 31 31 20 23 66 29 29 0a 09 20 20 28 tor 11 #f)).. (
14d70 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 rmt:testmeta-add
14d80 2d 72 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d -record test-nam
14d90 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 e))). (for-ea
14da0 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
14db0 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 6c (key). (l
14dc0 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 20 et* ((idx (cadr
14dd0 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 6c key)).. (fl
14de0 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 20 d (car key))..
14df0 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 (val (confi
14e00 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f g-lookup test-co
14e10 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 66 nf "test_meta" f
14e20 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 ld))).. ;; (debu
14e30 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a 20 g:print 5 "idx:
14e40 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 66 " idx " fld: " f
14e50 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 ld " val: " val)
14e60 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c 20 .. (if (and val
14e70 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 65 (not (equal? (ve
14e80 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 63 ctor-ref currrec
14e90 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 0a ord idx) val))).
14ea0 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
14eb0 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 64 (print "Upd
14ec0 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d ating " test-nam
14ed0 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 22 e " " fld " to "
14ee0 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 72 val).. (r
14ef0 6d 74 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 mt:testmeta-upda
14f00 74 65 2d 66 69 65 6c 64 20 74 65 73 74 2d 6e 61 te-field test-na
14f10 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a me fld val))))).
14f20 20 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 '(("author"
14f30 20 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 2)("owner" 3)("
14f40 64 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 description" 4)(
14f50 22 72 65 76 69 65 77 65 64 22 20 35 29 28 22 74 "reviewed" 5)("t
14f60 61 67 73 22 20 39 29 28 22 6a 6f 62 67 72 6f 75 ags" 9)("jobgrou
14f70 70 22 20 31 30 29 29 29 29 29 0a 0a 3b 3b 20 55 p" 10)))))..;; U
14f80 70 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 pdate test_meta
14f90 66 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 for all tests.(d
14fa0 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 efine (runs:upda
14fb0 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 te-all-test_meta
14fc0 20 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 db). (let ((te
14fd0 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a st-names (tests:
14fe0 67 65 74 2d 61 6c 6c 29 29 29 20 3b 3b 20 28 74 get-all))) ;; (t
14ff0 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 ests:get-valid-t
15000 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 ests))). (for
15010 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
15020 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a bda (test-name).
15030 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
15040 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 6d 74 3a est-conf (mt:
15050 6c 61 7a 79 2d 72 65 61 64 2d 74 65 73 74 2d 63 lazy-read-test-c
15060 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 29 onfig test-name)
15070 29 29 0a 09 20 28 69 66 20 74 65 73 74 2d 63 6f )).. (if test-co
15080 6e 66 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d nf (runs:update-
15090 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e test_meta test-n
150a0 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 ame test-conf)))
150b0 29 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 ). (hash-tab
150c0 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 6e 61 6d le-keys test-nam
150d0 65 73 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 es))))..;; This
150e0 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 could probably b
150f0 65 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 e refactored int
15100 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 o one complex qu
15110 65 72 79 20 2e 2e 2e 0a 3b 3b 20 4e 4f 54 20 50 ery ....;; NOT P
15120 4f 52 54 45 44 20 2d 20 44 4f 20 4e 4f 54 20 55 ORTED - DO NOT U
15130 53 45 20 59 45 54 0a 3b 3b 0a 28 64 65 66 69 6e SE YET.;;.(defin
15140 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 e (runs:rollup-r
15150 75 6e 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 un keys runname
15160 75 73 65 72 20 6b 65 79 76 61 6c 73 29 0a 20 20 user keyvals).
15170 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
15180 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c runs:rollup-run,
15190 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 keys: " keys "
151a0 2d 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 -runname " runna
151b0 6d 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 me " user: " use
151c0 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 r). (let* ((db
151d0 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
151e0 0a 09 20 3b 3b 20 72 65 67 69 73 74 65 72 20 72 .. ;; register r
151f0 75 6e 20 6f 70 65 72 61 74 65 73 20 6f 6e 20 74 un operates on t
15200 68 65 20 6d 61 69 6e 20 64 62 0a 09 20 28 6e 65 he main db.. (ne
15210 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 w-run-id (r
15220 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 mt:register-run
15230 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 keyvals runname
15240 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
15250 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 )).. (prev-tests
15260 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6d (rmt:get-m
15270 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
15280 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
15290 73 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 s new-run-id "%"
152a0 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 2d 74 "%")).. (curr-t
152b0 65 73 74 73 20 20 20 20 20 20 28 6d 74 3a 67 65 ests (mt:ge
152c0 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
152d0 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 new-run-id "%/%"
152e0 20 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 '() '())).. (cu
152f0 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d rr-tests-hash (m
15300 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
15310 29 0a 20 20 20 20 28 72 6d 74 3a 75 70 64 61 74 ). (rmt:updat
15320 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 e-run-event_time
15330 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 new-run-id).
15340 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c ;; index the al
15350 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 ready saved test
15360 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e s by testname an
15370 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 d itemdat in cur
15380 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 r-tests-hash.
15390 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
153a0 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 (lambda (testdat
153b0 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
153c0 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 (testname (db:t
153d0 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
153e0 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
153f0 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 (item-path (db
15400 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
15410 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
15420 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
15430 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 (conc testname "
15440 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a /" item-path))).
15450 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
15460 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
15470 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 sh full-name tes
15480 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 tdat))). cur
15490 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 r-tests). ;;
154a0 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 NOPE: Non-optima
154b0 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 l approach. Try
154c0 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 this instead..
154d0 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 ;; 1. tests
154e0 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 are received in
154f0 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 a list, most rec
15500 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b ent first. ;;
15510 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 2. replace th
15520 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 e rollup test wi
15530 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 th the new *alwa
15540 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ys*. (for-eac
15550 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
15560 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 (testdat).
15570 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d (let* ((testnam
15580 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d e (db:test-get-
15590 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
155a0 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d )).. (item-
155b0 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 path (db:test-ge
155c0 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
155d0 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 dat)).. (fu
155e0 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 ll-name (conc te
155f0 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
15600 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 path)).. (p
15610 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 rev-test-dat (ha
15620 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
15630 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d ault curr-tests-
15640 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 hash full-name #
15650 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
15660 2d 73 74 65 70 73 20 20 20 20 28 72 6d 74 3a 67 -steps (rmt:g
15670 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
15680 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 t (db:test-get-i
15690 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
156a0 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 (new-test-re
156b0 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 cord #f)).. ;; r
156c0 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 eplace these wit
156d0 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c h insert ... sel
156e0 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c ect.. (apply sql
156f0 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 ite3:execute ...
15700 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 db ...(conc "INS
15710 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
15720 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 NTO tests (run_i
15730 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 d,testname,state
15740 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
15750 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c me,host,cpuload,
15760 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 diskfree,uname,r
15770 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c undir,item_path,
15780 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e run_duration,fin
15790 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 al_logf,comment)
157a0 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 "... "VALU
157b0 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ES (?,?,?,?,?,?,
157c0 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 ?,?,?,?,?,?,?,?)
157d0 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 ;")...new-run-id
157e0 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e (cddr (vector->
157f0 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a list testdat))).
15800 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 . (set! new-test
15810 64 61 74 20 28 63 61 72 20 28 6d 74 3a 67 65 74 dat (car (mt:get
15820 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e -tests-for-run n
15830 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 ew-run-id (conc
15840 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
15850 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 29 m-path) '() '())
15860 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 )).. (hash-table
15870 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 -set! curr-tests
15880 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
15890 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 new-testdat) ;;
158a0 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f this could be co
158b0 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 nfusing, which r
158c0 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 ecord should go
158d0 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 into the lookup
158e0 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 table?.. ;; Now
158f0 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
15900 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 st steps.. (debu
15910 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
15920 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
15930 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 st_steps from te
15940 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
15950 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
15960 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
15970 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
15980 64 61 74 29 29 0a 09 20 28 63 64 62 3a 72 65 6d dat)).. (cdb:rem
15990 6f 74 65 2d 72 75 6e 20 3b 3b 20 74 6f 20 62 65 ote-run ;; to be
159a0 20 72 65 70 6c 61 63 65 64 2c 20 6e 6f 74 65 3a replaced, note:
159b0 20 74 68 69 73 20 72 6f 75 74 69 6e 65 20 69 73 this routine is
159c0 20 6e 6f 74 20 75 73 65 64 20 63 75 72 72 65 6e not used curren
159d0 74 6c 79 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 tly.. (lambda (
159e0 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ).. (sqlite3:
159f0 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 execute .. d
15a00 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 b .. (conc "
15a10 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
15a20 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 E INTO test_step
15a30 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e s (test_id,stepn
15a40 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
15a50 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d ,event_time,comm
15a60 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
15a70 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
15a80 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
15a90 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t) ",stepname,st
15aa0 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
15ab0 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 _time,comment FR
15ac0 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 OM test_steps WH
15ad0 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 ERE test_id=?;")
15ae0 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d .. (db:test-
15af0 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 get-id testdat))
15b00 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 .. ;; Now dup
15b10 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
15b20 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 75 67 data.. (debug
15b30 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e :print 4 "Copyin
15b40 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 g records in tes
15b50 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 t_data from test
15b60 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 _id=" (db:test-g
15b70 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 et-id testdat) "
15b80 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 to " (db:test-g
15b90 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
15ba0 74 29 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 t)).. (sqlite
15bb0 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 3:execute ..
15bc0 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 db .. (conc
15bd0 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
15be0 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 ACE INTO test_da
15bf0 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 ta (test_id,cate
15c00 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 gory,variable,va
15c10 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c lue,expected,tol
15c20 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 ,units,comment)
15c30 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 "... "SELECT "
15c40 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
15c50 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c new-testdat) ",
15c60 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c category,variabl
15c70 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 e,value,expected
15c80 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 ,tol,units,comme
15c90 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 nt FROM test_dat
15ca0 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d a WHERE test_id=
15cb0 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 ?;").. (db:t
15cc0 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
15cd0 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 at)))).. )).
15ce0 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 prev-tests)))..
15cf0 20 0a 20 20 20 20 20 0a . .