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 6d 74 3a 72 6f 6c 6c 2d 75 70 (mt:roll-up
a1d0: 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 -pass-fail-count
a1e0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
a1f0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 22 46 41 me item-path "FA
a200: 49 4c 22 29 20 3b 3b 20 74 72 65 61 74 20 61 73 IL") ;; treat as
a210: 20 46 41 49 4c 0a 09 09 20 20 20 20 20 20 28 6c FAIL... (l
a220: 69 73 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 ist (if (null? t
a230: 61 6c 29 28 63 61 72 20 6e 65 77 74 61 6c 29 28 al)(car newtal)(
a240: 63 61 72 20 74 61 6c 29 29 0a 09 09 09 20 20 20 car tal))....
a250: 20 74 61 6c 0a 09 09 09 20 20 20 20 72 65 67 0a tal.... reg.
a260: 09 09 09 20 20 20 20 72 65 72 75 6e 73 29 29 29 ... reruns)))
a270: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 63 61 6e )).. ;; can
a280: 27 74 20 64 72 6f 70 20 74 68 69 73 20 2d 20 6d 't drop this - m
a290: 61 79 62 65 20 72 75 6e 6e 69 6e 67 3f 20 4a 75 aybe running? Ju
a2a0: 73 74 20 6b 65 65 70 20 74 72 79 69 6e 67 0a 09 st keep trying..
a2b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e (let ((run
a2c0: 61 62 6c 65 2d 74 65 73 74 73 20 28 72 75 6e 73 able-tests (runs
a2d0: 3a 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 20 70 :runable-tests p
a2e0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
a2f0: 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 72 )...(if (null? r
a300: 75 6e 61 62 6c 65 2d 74 65 73 74 73 29 0a 09 09 unable-tests)...
a310: 20 20 20 20 23 66 20 20 20 3b 3b 20 49 20 74 68 #f ;; I th
a320: 69 6e 6b 20 77 65 20 61 72 65 20 74 72 75 6c 79 ink we are truly
a330: 20 64 6f 6e 65 20 68 65 72 65 0a 09 09 20 20 20 done here...
a340: 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 (list (runs:que
a350: 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e 65 77 74 ue-next-hed newt
a360: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
a370: 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 gfull).... (r
a380: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 uns:queue-next-t
a390: 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 al newtal reg re
a3a0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
a3b0: 09 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 . (runs:queue
a3c0: 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 74 61 6c -next-reg newtal
a3d0: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
a3e0: 75 6c 6c 29 0a 09 09 09 20 20 20 20 72 65 72 75 ull).... reru
a3f0: 6e 73 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 ns)))))))))..;;
a400: 73 63 61 6e 20 61 20 6c 69 73 74 20 6f 66 20 74 scan a list of t
a410: 65 73 74 73 20 6c 6f 6f 6b 69 6e 67 20 74 6f 20 ests looking to
a420: 73 65 65 20 69 66 20 61 6e 79 20 61 72 65 20 70 see if any are p
a430: 6f 74 65 6e 74 69 61 6c 6c 79 20 72 75 6e 6e 61 otentially runna
a440: 62 6c 65 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ble.(define (run
a450: 73 3a 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 20 s:runable-tests
a460: 74 65 73 74 73 29 0a 20 20 28 66 69 6c 74 65 72 tests). (filter
a470: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 20 (lambda (t)..
a480: 20 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 (if (not (vect
a490: 6f 72 3f 20 74 29 29 0a 09 09 74 0a 09 09 28 6c or? t))...t...(l
a4a0: 65 74 20 28 28 73 74 61 74 65 20 20 28 64 62 3a et ((state (db:
a4b0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
a4c0: 29 29 0a 09 09 20 20 20 20 20 20 28 73 74 61 74 ))... (stat
a4d0: 75 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d us (db:test-get-
a4e0: 73 74 61 74 75 73 20 74 29 29 29 0a 09 09 20 20 status t)))...
a4f0: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
a500: 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a 09 09 20 ymbol state)...
a510: 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 29 20 ((COMPLETED)
a520: 23 66 29 0a 09 09 20 20 20 20 28 28 4e 4f 54 5f #f)... ((NOT_
a530: 53 54 41 52 54 45 44 29 0a 09 09 20 20 20 20 20 STARTED)...
a540: 28 69 66 20 28 6d 65 6d 62 65 72 20 73 74 61 74 (if (member stat
a550: 75 73 20 27 28 22 54 45 4e 5f 53 54 52 49 4b 45 us '("TEN_STRIKE
a560: 53 22 20 22 42 4c 4f 43 4b 45 44 22 20 22 50 52 S" "BLOCKED" "PR
a570: 45 51 5f 46 41 49 4c 22 20 22 5a 45 52 4f 5f 49 EQ_FAIL" "ZERO_I
a580: 54 45 4d 53 22 20 22 50 52 45 51 5f 44 49 53 43 TEMS" "PREQ_DISC
a590: 41 52 44 45 44 22 20 22 54 49 4d 45 44 5f 4f 55 ARDED" "TIMED_OU
a5a0: 54 22 20 29 29 0a 09 09 09 20 23 66 0a 09 09 09 T" )).... #f....
a5b0: 20 74 29 29 0a 09 09 20 20 20 20 28 28 44 45 4c t))... ((DEL
a5c0: 45 54 45 44 29 20 23 66 29 0a 09 09 20 20 20 20 ETED) #f)...
a5d0: 28 65 6c 73 65 20 74 29 29 29 29 29 0a 09 20 20 (else t)))))..
a5e0: 74 65 73 74 73 29 29 0a 0a 3b 3b 20 65 76 65 72 tests))..;; ever
a5f0: 79 20 74 69 6d 65 20 74 68 6f 75 67 68 20 74 68 y time though th
a600: 65 20 6c 6f 6f 70 20 69 6e 63 72 65 6d 65 6e 74 e loop increment
a610: 20 74 68 65 20 74 65 73 74 2f 69 74 65 6d 70 61 the test/itempa
a620: 74 74 20 76 61 6c 2e 0a 3b 3b 20 77 68 65 6e 20 tt val..;; when
a630: 74 68 65 20 6d 69 6e 20 69 73 20 3e 20 6d 61 78 the min is > max
a640: 2d 61 6c 6c 6f 77 65 64 20 61 6e 64 20 6e 6f 6e -allowed and non
a650: 65 20 72 75 6e 6e 69 6e 67 20 74 68 65 6e 20 66 e running then f
a660: 6f 72 63 65 20 65 78 69 74 0a 3b 3b 0a 28 64 65 orce exit.;;.(de
a670: 66 69 6e 65 20 2a 6d 61 78 2d 74 72 69 65 73 2d fine *max-tries-
a680: 68 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 hash* (make-hash
a690: 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 74 65 73 -table))..;; tes
a6a0: 74 2d 72 65 63 6f 72 64 73 20 69 73 20 61 20 68 t-records is a h
a6b0: 61 73 68 20 74 61 62 6c 65 20 74 65 73 74 6e 61 ash table testna
a6c0: 6d 65 3a 69 74 65 6d 5f 70 61 74 68 20 3d 3e 20 me:item_path =>
a6d0: 76 65 63 74 6f 72 20 3c 20 74 65 73 74 6e 61 6d vector < testnam
a6e0: 65 20 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 e testconfig wai
a6f0: 74 6f 6e 73 20 70 72 69 6f 72 69 74 79 20 69 74 tons priority it
a700: 65 6d 73 2d 69 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 ems-info ... >.(
a710: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e define (runs:run
a720: 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 6e -tests-queue run
a730: 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 -id runname test
a740: 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 73 -records keyvals
a750: 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 74 flags test-patt
a760: 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 s required-tests
a770: 20 72 65 67 6c 65 6e 2d 69 6e 20 61 6c 6c 2d 74 reglen-in all-t
a780: 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 ests-registry).
a790: 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 6e ;; At this poin
a7a0: 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 61 t the list of pa
a7b0: 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 78 rent tests is ex
a7c0: 70 61 6e 64 65 64 20 0a 20 20 3b 3b 20 4e 42 2f panded . ;; NB/
a7d0: 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 20 / Should expand
a7e0: 69 74 65 6d 73 20 68 65 72 65 20 61 6e 64 20 74 items here and t
a7f0: 68 65 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f 20 hen insert into
a800: 74 68 65 20 72 75 6e 20 71 75 65 75 65 2e 0a 20 the run queue..
a810: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
a820: 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 22 "test-records: "
a830: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 2c test-records ",
a840: 20 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 2d flags: " (hash-
a850: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 table->alist fla
a860: 67 73 29 29 0a 0a 20 20 3b 3b 20 44 6f 20 6d 61 gs)).. ;; Do ma
a870: 72 6b 2d 61 6e 64 2d 66 69 6e 64 20 63 6c 65 61 rk-and-find clea
a880: 6e 20 75 70 20 6f 66 20 64 62 20 62 65 66 6f 72 n up of db befor
a890: 65 20 73 74 61 72 74 69 6e 67 20 72 75 6e 69 6e e starting runin
a8a0: 67 20 6f 66 20 71 75 75 65 0a 20 20 3b 3b 0a 20 g of quue. ;;.
a8b0: 20 3b 3b 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e ;; (rmt:find-an
a8c0: 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 d-mark-incomplet
a8d0: 65 29 0a 0a 20 20 28 6c 65 74 20 28 28 72 75 6e e).. (let ((run
a8e0: 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 20 20 -info
a8f0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d (rmt:get-run-
a900: 69 6e 66 6f 20 72 75 6e 2d 69 64 29 29 0a 09 28 info run-id))..(
a910: 74 65 73 74 73 2d 69 6e 66 6f 20 20 20 20 20 20 tests-info
a920: 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d 74 65 (mt:get-te
a930: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d sts-for-run run-
a940: 69 64 20 23 66 20 27 28 29 20 27 28 29 29 29 20 id #f '() '()))
a950: 3b 3b 20 20 71 72 79 76 61 6c 73 3a 20 22 69 64 ;; qryvals: "id
a960: 2c 74 65 73 74 6e 61 6d 65 2c 69 74 65 6d 5f 70 ,testname,item_p
a970: 61 74 68 22 29 29 0a 09 28 73 6f 72 74 65 64 2d ath"))..(sorted-
a980: 74 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 28 test-names (
a990: 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 tests:sort-by-pr
a9a0: 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f iority-and-waito
a9b0: 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 n test-records))
a9c0: 0a 09 28 74 65 73 74 2d 72 65 67 69 73 74 72 79 ..(test-registry
a9d0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
a9e0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 72 65 ash-table))..(re
a9f0: 67 69 73 74 72 79 2d 6d 75 74 65 78 20 20 20 20 gistry-mutex
aa00: 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 (make-mutex)
aa10: 29 0a 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 20 )..(num-retries
aa20: 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 6d 0)..(m
aa30: 61 78 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 ax-retries
aa40: 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (config-loo
aa50: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
aa60: 22 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 "setup" "maxretr
aa70: 69 65 73 22 29 29 0a 09 28 6d 61 78 2d 63 6f 6e ies"))..(max-con
aa80: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 28 current-jobs (
aa90: 6c 65 74 20 28 28 6d 63 6a 20 28 63 6f 6e 66 69 let ((mcj (confi
aaa0: 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 g-lookup *config
aab0: 64 61 74 2a 20 22 73 65 74 75 70 22 20 20 20 20 dat* "setup"
aac0: 20 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 "max_concurrent
aad0: 5f 6a 6f 62 73 22 29 29 29 0a 09 09 09 09 20 28 _jobs")))..... (
aae0: 69 66 20 28 61 6e 64 20 6d 63 6a 20 28 73 74 72 if (and mcj (str
aaf0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 ing->number mcj)
ab00: 29 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 )..... (stri
ab10: 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 0a ng->number mcj).
ab20: 09 09 09 09 20 20 20 20 20 31 29 29 29 20 3b 3b .... 1))) ;;
ab30: 20 6c 65 6e 67 74 68 20 6f 66 20 74 68 65 20 72 length of the r
ab40: 65 67 69 73 74 65 72 20 71 75 65 75 65 20 61 68 egister queue ah
ab50: 65 61 64 0a 09 28 72 65 67 6c 65 6e 20 20 20 20 ead..(reglen
ab60: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
ab70: 28 6e 75 6d 62 65 72 3f 20 72 65 67 6c 65 6e 2d (number? reglen-
ab80: 69 6e 29 20 72 65 67 6c 65 6e 2d 69 6e 20 31 29 in) reglen-in 1)
ab90: 29 0a 09 28 6c 61 73 74 2d 74 69 6d 65 2d 69 6e )..(last-time-in
aba0: 63 6f 6d 70 6c 65 74 65 20 20 28 2d 20 28 63 75 complete (- (cu
abb0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 39 rrent-seconds) 9
abc0: 30 30 29 29 20 3b 3b 20 66 6f 72 63 65 20 61 74 00)) ;; force at
abd0: 20 6c 65 61 73 74 20 6f 6e 65 20 63 6c 65 61 6e least one clean
abe0: 20 75 70 20 63 79 63 6c 65 0a 09 28 6c 61 73 74 up cycle..(last
abf0: 2d 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 -time-some-runni
ac00: 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ng (current-seco
ac10: 6e 64 73 29 29 0a 09 28 74 64 62 64 61 74 20 20 nds))..(tdbdat
ac20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
ac30: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a asks:open-db))).
ac40: 0a 20 20 20 20 3b 3b 20 49 6e 69 74 69 61 6c 69 . ;; Initiali
ac50: 7a 65 20 74 68 65 20 74 65 73 74 2d 72 65 67 69 ze the test-regi
ac60: 73 74 65 72 79 20 68 61 73 68 20 77 69 74 68 20 stery hash with
ac70: 74 65 73 74 73 20 74 68 61 74 20 61 6c 72 65 61 tests that alrea
ac80: 64 79 20 68 61 76 65 20 61 20 72 65 63 6f 72 64 dy have a record
ac90: 0a 20 20 20 20 3b 3b 20 63 6f 6e 76 65 72 74 20 . ;; convert
aca0: 73 74 61 74 65 20 74 6f 20 73 79 6d 62 6f 6c 20 state to symbol
acb0: 61 6e 64 20 75 73 65 20 74 68 61 74 20 61 73 20 and use that as
acc0: 74 68 65 20 68 61 73 68 20 76 61 6c 75 65 0a 20 the hash value.
acd0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
ace0: 6d 62 64 61 20 28 74 72 65 63 29 0a 09 09 28 6c mbda (trec)...(l
acf0: 65 74 20 28 28 69 64 20 28 64 62 3a 74 65 73 74 et ((id (db:test
ad00: 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 74 -get-id t
ad10: 72 65 63 29 29 0a 09 09 20 20 20 20 20 20 28 74 rec))... (t
ad20: 6e 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 n (db:test-get-t
ad30: 65 73 74 6e 61 6d 65 20 20 74 72 65 63 29 29 0a estname trec)).
ad40: 09 09 20 20 20 20 20 20 28 69 70 20 28 64 62 3a .. (ip (db:
ad50: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
ad60: 74 68 20 74 72 65 63 29 29 0a 09 09 20 20 20 20 th trec))...
ad70: 20 20 28 73 74 20 28 64 62 3a 74 65 73 74 2d 67 (st (db:test-g
ad80: 65 74 2d 73 74 61 74 65 20 20 20 20 20 74 72 65 et-state tre
ad90: 63 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f c)))... (if (no
ada0: 74 20 28 65 71 75 61 6c 3f 20 73 74 20 22 44 45 t (equal? st "DE
adb0: 4c 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 LETED"))...
adc0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
add0: 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
ade0: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
adf0: 6c 6c 2d 6e 61 6d 65 20 74 6e 20 69 70 29 20 28 ll-name tn ip) (
ae00: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 string->symbol s
ae10: 74 29 29 29 29 29 0a 09 20 20 20 20 20 20 74 65 t))))).. te
ae20: 73 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 28 73 sts-info). (s
ae30: 65 74 21 20 6d 61 78 2d 72 65 74 72 69 65 73 20 et! max-retries
ae40: 28 69 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 (if (and max-ret
ae50: 72 69 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 ries (string->nu
ae60: 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 mber max-retries
ae70: 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ))(string->numbe
ae80: 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 20 31 r max-retries) 1
ae90: 30 30 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 6c 00)).. (let l
aea0: 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 20 oop ((hed
aeb0: 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 (car sorted-te
aec0: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 st-names))..
aed0: 20 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 (tal
aee0: 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (cdr sorted-test
aef0: 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 20 -names))..
af00: 20 28 72 65 67 20 20 20 20 20 20 20 20 20 27 28 (reg '(
af10: 29 29 20 3b 3b 20 72 65 67 69 73 74 65 72 65 64 )) ;; registered
af20: 2c 20 70 75 74 20 74 68 65 73 65 20 61 74 20 74 , put these at t
af30: 68 65 20 68 65 61 64 20 6f 66 20 74 61 6c 20 0a he head of tal .
af40: 09 20 20 20 20 20 20 20 28 72 65 72 75 6e 73 20 . (reruns
af50: 20 20 20 20 20 27 28 29 29 29 0a 0a 20 20 20 20 '()))..
af60: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
af70: 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 67 ? reruns))(debug
af80: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
af90: 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 eruns=" reruns))
afa0: 0a 0a 20 20 20 20 20 20 3b 3b 20 48 65 72 65 20 .. ;; Here
afb0: 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f 6c 64 20 we mark any old
afc0: 64 65 66 75 6e 63 74 20 74 65 73 74 73 20 61 73 defunct tests as
afd0: 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 44 6f 20 incomplete. Do
afe0: 74 68 69 73 20 65 76 65 72 79 20 66 69 66 74 65 this every fifte
aff0: 65 6e 20 6d 69 6e 75 74 65 73 0a 20 20 20 20 20 en minutes.
b000: 20 3b 3b 20 6d 6f 76 69 6e 67 20 74 68 69 73 20 ;; moving this
b010: 74 6f 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 to a parallel th
b020: 72 65 61 64 20 61 6e 64 20 6a 75 73 74 20 72 75 read and just ru
b030: 6e 20 69 74 20 6f 6e 63 65 2e 0a 20 20 20 20 20 n it once..
b040: 20 3b 3b 0a 20 20 20 20 20 20 28 69 66 20 28 3e ;;. (if (>
b050: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
b060: 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 2d 69 s)(+ last-time-i
b070: 6e 63 6f 6d 70 6c 65 74 65 20 39 30 30 29 29 0a ncomplete 900)).
b080: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
b090: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 . (se
b0a0: 74 21 20 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 t! last-time-inc
b0b0: 6f 6d 70 6c 65 74 65 20 28 63 75 72 72 65 6e 74 omplete (current
b0c0: 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 -seconds)).
b0d0: 20 20 20 20 20 20 20 3b 3b 20 28 72 6d 74 3a 66 ;; (rmt:f
b0e0: 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 ind-and-mark-inc
b0f0: 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 omplete-all-runs
b100: 29 0a 09 20 20 20 20 29 29 0a 0a 20 20 20 20 20 ).. ))..
b110: 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f 70 20 ;; (print "Top
b120: 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 68 of loop, hed=" h
b130: 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c 20 ed ", tal=" tal
b140: 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 72 75 " ,reruns=" reru
b150: 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 ns). (let*
b160: 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 ((test-record (h
b170: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
b180: 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 st-records hed))
b190: 0a 09 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d .. (test-nam
b1a0: 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 e (tests:testq
b1b0: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
b1c0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a e test-record)).
b1d0: 09 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 20 . (tconfig
b1e0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
b1f0: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
b200: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
b210: 0a 09 20 20 20 20 20 28 6a 6f 62 67 72 6f 75 70 .. (jobgroup
b220: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
b230: 75 70 20 74 63 6f 6e 66 69 67 20 22 74 65 73 74 up tconfig "test
b240: 5f 6d 65 74 61 22 20 22 6a 6f 62 67 72 6f 75 70 _meta" "jobgroup
b250: 22 29 29 0a 09 20 20 20 20 20 28 74 65 73 74 6d ")).. (testm
b260: 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d 20 ode (let ((m
b270: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
b280: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
b290: 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 0a ents" "mode"))).
b2a0: 09 09 09 20 20 20 20 28 69 66 20 6d 20 28 6d 61 ... (if m (ma
b2b0: 70 20 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c p string->symbol
b2c0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6d (string-split m
b2d0: 29 29 20 27 28 6e 6f 72 6d 61 6c 29 29 29 29 0a )) '(normal)))).
b2e0: 09 20 20 20 20 20 28 69 74 65 6d 6d 61 70 20 20 . (itemmap
b2f0: 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b (configf:look
b300: 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 up tconfig "requ
b310: 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d 6d irements" "itemm
b320: 61 70 22 29 29 0a 09 20 20 20 20 20 28 77 61 69 ap")).. (wai
b330: 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a tons (tests:
b340: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
b350: 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 itons test-re
b360: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 70 72 cord)).. (pr
b370: 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 73 iority (tests
b380: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 :testqueue-get-p
b390: 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 riority test-r
b3a0: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 69 ecord)).. (i
b3b0: 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 temdat (test
b3c0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
b3d0: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
b3e0: 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d record)) ;; item
b3f0: 64 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 dat can be a str
b400: 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a ing, list or #f.
b410: 09 20 20 20 20 20 28 69 74 65 6d 73 20 20 20 20 . (items
b420: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
b430: 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 20 20 20 eue-get-items
b440: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
b450: 0a 09 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 .. (item-pat
b460: 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e h (item-list->
b470: 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 path itemdat))..
b480: 20 20 20 20 20 28 74 66 75 6c 6c 6e 61 6d 65 20 (tfullname
b490: 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d (db:test-make-
b4a0: 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e full-name test-n
b4b0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a ame item-path)).
b4c0: 09 20 20 20 20 20 28 6e 65 77 74 61 6c 20 20 20 . (newtal
b4d0: 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 (append tal (
b4e0: 6c 69 73 74 20 68 65 64 29 29 29 0a 09 20 20 20 list hed)))..
b4f0: 20 20 28 72 65 67 66 75 6c 6c 20 20 20 20 20 28 (regfull (
b500: 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 67 29 20 >= (length reg)
b510: 72 65 67 6c 65 6e 29 29 0a 09 20 20 20 20 20 28 reglen)).. (
b520: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 72 6d 74 num-running (rmt
b530: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
b540: 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e -running-for-run
b550: 2d 69 64 20 72 75 6e 2d 69 64 29 29 29 0a 0a 09 -id run-id)))...
b560: 3b 3b 20 65 76 65 72 79 20 63 6f 75 70 6c 65 20 ;; every couple
b570: 6d 69 6e 75 74 65 73 20 76 65 72 69 66 79 20 74 minutes verify t
b580: 68 65 20 73 65 72 76 65 72 20 69 73 20 74 68 65 he server is the
b590: 72 65 20 66 6f 72 20 74 68 69 73 20 72 75 6e 0a re for this run.
b5a0: 09 28 69 66 20 28 61 6e 64 20 28 63 6f 6d 6d 6f .(if (and (commo
b5b0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
b5c0: 74 20 36 30 20 22 74 72 79 20 73 74 61 72 74 20 t 60 "try start
b5d0: 73 65 72 76 65 72 22 20 20 72 75 6e 2d 69 64 29 server" run-id)
b5e0: 0a 09 09 20 28 74 61 73 6b 73 3a 6e 65 65 64 2d ... (tasks:need-
b5f0: 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 29 0a server run-id)).
b600: 09 20 20 20 20 28 74 61 73 6b 73 3a 73 74 61 72 . (tasks:star
b610: 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d 73 t-and-wait-for-s
b620: 65 72 76 65 72 20 74 64 62 64 61 74 20 72 75 6e erver tdbdat run
b630: 2d 69 64 20 31 30 29 29 20 3b 3b 20 4e 4f 54 45 -id 10)) ;; NOTE
b640: 3a 20 64 65 6c 61 79 20 61 6e 64 20 77 61 69 74 : delay and wait
b650: 20 69 73 20 64 6f 6e 65 20 75 6e 64 65 72 20 74 is done under t
b660: 68 65 20 68 6f 6f 64 0a 09 0a 09 28 69 66 20 28 he hood....(if (
b670: 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 > num-running 0)
b680: 0a 09 20 20 28 73 65 74 21 20 6c 61 73 74 2d 74 .. (set! last-t
b690: 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 ime-some-running
b6a0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
b6b0: 73 29 29 29 0a 0a 20 20 20 20 20 20 28 69 66 20 s))).. (if
b6c0: 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (> (current-seco
b6d0: 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 nds)(+ last-time
b6e0: 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 28 6f -some-running (o
b6f0: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
b700: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
b710: 65 74 75 70 22 20 22 67 69 76 65 2d 75 70 2d 77 etup" "give-up-w
b720: 61 69 74 69 6e 67 22 29 20 33 36 30 30 30 29 29 aiting") 36000))
b730: 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ).. (hash-table
b740: 2d 73 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 73 -set! *max-tries
b750: 2d 68 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d 65 -hash* tfullname
b760: 20 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (+ (hash-table-
b770: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 6d 61 78 ref/default *max
b780: 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 74 66 75 -tries-hash* tfu
b790: 6c 6c 6e 61 6d 65 20 30 29 20 31 29 29 29 0a 09 llname 0) 1)))..
b7a0: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
b7b0: 30 20 22 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 0 "max-tries-has
b7c0: 68 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 h: " (hash-table
b7d0: 2d 3e 61 6c 69 73 74 20 2a 6d 61 78 2d 74 72 69 ->alist *max-tri
b7e0: 65 73 2d 68 61 73 68 2a 29 29 0a 0a 09 3b 3b 20 es-hash*))...;;
b7f0: 45 6e 73 75 72 65 20 61 6c 6c 20 74 6f 70 20 6c Ensure all top l
b800: 65 76 65 6c 20 74 65 73 74 73 20 67 65 74 20 72 evel tests get r
b810: 65 67 69 73 74 65 72 65 64 2e 20 54 68 69 73 20 egistered. This
b820: 77 61 79 20 74 68 65 79 20 73 68 6f 77 20 75 70 way they show up
b830: 20 61 73 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 as "NOT_STARTED
b840: 22 20 6f 6e 20 74 68 65 20 64 61 73 68 62 6f 61 " on the dashboa
b850: 72 64 0a 09 3b 3b 20 61 6e 64 20 69 74 20 69 73 rd..;; and it is
b860: 20 63 6c 65 61 72 20 74 68 65 79 20 2a 73 68 6f clear they *sho
b870: 75 6c 64 2a 20 68 61 76 65 20 72 75 6e 20 62 75 uld* have run bu
b880: 74 20 64 69 64 20 6e 6f 74 2e 0a 09 28 69 66 20 t did not...(if
b890: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
b8a0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
b8b0: 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 t-registry (db:t
b8c0: 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 est-make-full-na
b8d0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 me test-name "")
b8e0: 20 23 66 29 29 0a 09 20 20 20 20 28 62 65 67 69 #f)).. (begi
b8f0: 6e 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 67 65 n.. (rmt:ge
b900: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 neral-call 'regi
b910: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
b920: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
b930: 65 20 22 22 29 0a 09 20 20 20 20 20 20 28 68 61 e "").. (ha
b940: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
b950: 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a st-registry (db:
b960: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
b970: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 ame test-name ""
b980: 29 20 27 64 6f 6e 65 29 29 29 0a 09 0a 09 3b 3b ) 'done)))....;;
b990: 20 46 61 73 74 20 73 6b 69 70 20 6f 66 20 74 65 Fast skip of te
b9a0: 73 74 73 20 74 68 61 74 20 61 72 65 20 61 6c 72 sts that are alr
b9b0: 65 61 64 79 20 22 43 4f 4d 50 4c 45 54 45 44 22 eady "COMPLETED"
b9c0: 20 2d 20 4e 4f 21 20 43 61 6e 6e 6f 74 20 64 6f - NO! Cannot do
b9d0: 20 74 68 61 74 20 61 73 20 74 68 65 20 69 74 65 that as the ite
b9e0: 6d 73 20 6d 61 79 20 6e 6f 74 20 68 61 76 65 20 ms may not have
b9f0: 62 65 65 6e 20 65 78 70 61 6e 64 65 64 20 79 65 been expanded ye
ba00: 74 20 3a 28 0a 09 3b 3b 0a 09 28 69 66 20 28 6d t :(..;;..(if (m
ba10: 65 6d 62 65 72 20 28 68 61 73 68 2d 74 61 62 6c ember (hash-tabl
ba20: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
ba30: 73 74 2d 72 65 67 69 73 74 72 79 20 74 66 75 6c st-registry tful
ba40: 6c 6e 61 6d 65 20 23 66 29 20 0a 09 09 20 20 20 lname #f) ...
ba50: 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f '(DONOTRUN remo
ba60: 76 65 64 29 29 20 3b 3b 20 2a 63 6f 6d 6d 6f 6e ved)) ;; *common
ba70: 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 :cant-run-states
ba80: 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 43 4f 4d 50 -sym*) ;; '(COMP
ba90: 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 41 49 LETED KILLED WAI
baa0: 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e 43 4f VED UNKNOWN INCO
bab0: 4d 50 4c 45 54 45 29 29 0a 09 20 20 20 20 28 62 MPLETE)).. (b
bac0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 69 66 20 egin.. (if
bad0: 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 (runs:lownoise (
bae0: 63 6f 6e 63 20 22 62 65 65 6e 20 6d 61 72 6b 65 conc "been marke
baf0: 64 20 64 6f 20 6e 6f 74 20 72 75 6e 20 22 20 74 d do not run " t
bb00: 66 75 6c 6c 6e 61 6d 65 29 20 36 30 29 0a 09 09 fullname) 60)...
bb10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
bb20: 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 nfo 0 "Skipping
bb30: 74 65 73 74 20 22 20 74 66 75 6c 6c 6e 61 6d 65 test " tfullname
bb40: 20 22 20 61 73 20 69 74 20 68 61 73 20 62 65 65 " as it has bee
bb50: 6e 20 6d 61 72 6b 65 64 20 64 6f 20 6e 6f 74 20 n marked do not
bb60: 72 75 6e 20 64 75 65 20 74 6f 20 62 65 69 6e 67 run due to being
bb70: 20 63 6f 6d 70 6c 65 74 65 64 20 6f 72 20 6e 6f completed or no
bb80: 74 20 72 75 6e 6e 61 62 6c 65 22 29 29 0a 09 20 t runnable"))..
bb90: 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f (if (or (no
bba0: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 6e t (null? tal))(n
bbb0: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 ot (null? reg)))
bbc0: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 75 6e 73 ... (loop (runs
bbd0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
bbe0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
bbf0: 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 75 6e 73 egfull)....(runs
bc00: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
bc10: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
bc20: 65 67 66 75 6c 6c 29 0a 09 09 09 28 72 75 6e 73 egfull)....(runs
bc30: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
bc40: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
bc50: 65 67 66 75 6c 6c 29 0a 09 09 09 72 65 72 75 6e egfull)....rerun
bc60: 73 29 29 29 29 0a 09 09 20 20 3b 3b 20 28 6c 6f s))))... ;; (lo
bc70: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
bc80: 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 tal) reg reruns
bc90: 29 29 29 29 0a 0a 09 28 64 65 62 75 67 3a 70 72 ))))...(debug:pr
bca0: 69 6e 74 20 34 20 22 54 4f 50 20 4f 46 20 4c 4f int 4 "TOP OF LO
bcb0: 4f 50 20 3d 3e 20 22 0a 09 09 20 20 20 20 20 22 OP => "... "
bcc0: 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 test-name: " tes
bcd0: 74 2d 6e 61 6d 65 0a 09 09 20 20 20 20 20 22 5c t-name... "\
bce0: 6e 20 20 74 65 73 74 2d 72 65 63 6f 72 64 20 20 n test-record
bcf0: 22 20 74 65 73 74 2d 72 65 63 6f 72 64 0a 09 09 " test-record...
bd00: 20 20 20 20 20 22 5c 6e 20 20 68 65 64 3a 20 20 "\n hed:
bd10: 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 09 20 " hed...
bd20: 20 20 20 20 22 5c 6e 20 20 69 74 65 6d 64 61 74 "\n itemdat
bd30: 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 74 0a : " itemdat.
bd40: 09 09 20 20 20 20 20 22 5c 6e 20 20 69 74 65 6d .. "\n item
bd50: 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 6d 73 s: " items
bd60: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 69 74 65 ... "\n ite
bd70: 6d 2d 70 61 74 68 3a 20 20 20 22 20 69 74 65 6d m-path: " item
bd80: 2d 70 61 74 68 0a 09 09 20 20 20 20 20 22 5c 6e -path... "\n
bd90: 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 20 20 22 waitons: "
bda0: 20 77 61 69 74 6f 6e 73 0a 09 09 20 20 20 20 20 waitons...
bdb0: 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 69 65 73 "\n num-retries
bdc0: 3a 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 0a : " num-retries.
bdd0: 09 09 20 20 20 20 20 22 5c 6e 20 20 74 61 6c 3a .. "\n tal:
bde0: 20 20 20 20 20 20 20 20 20 22 20 74 61 6c 0a 09 " tal..
bdf0: 09 20 20 20 20 20 22 5c 6e 20 20 72 65 72 75 6e . "\n rerun
be00: 73 3a 20 20 20 20 20 20 22 20 72 65 72 75 6e 73 s: " reruns
be10: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 67 ... "\n reg
be20: 66 75 6c 6c 3a 20 20 20 20 20 22 20 72 65 67 66 full: " regf
be30: 75 6c 6c 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 ull... "\n
be40: 72 65 67 6c 65 6e 3a 20 20 20 20 20 20 22 20 72 reglen: " r
be50: 65 67 6c 65 6e 0a 09 09 20 20 20 20 20 22 5c 6e eglen... "\n
be60: 20 20 6c 65 6e 67 74 68 20 72 65 67 3a 20 20 22 length reg: "
be70: 20 28 6c 65 6e 67 74 68 20 72 65 67 29 0a 09 09 (length reg)...
be80: 20 20 20 20 20 22 5c 6e 20 20 72 65 67 3a 20 20 "\n reg:
be90: 20 20 20 20 20 20 20 22 20 72 65 67 29 0a 0a 09 " reg)...
bea0: 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 ;; check for hed
beb0: 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 in waitons => t
bec0: 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 his would be cir
bed0: 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 cular, remove it
bee0: 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 3b and issue an..;
bef0: 3b 20 65 72 72 6f 72 0a 09 28 69 66 20 28 6d 65 ; error..(if (me
bf00: 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 20 77 mber test-name w
bf10: 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 62 65 aitons).. (be
bf20: 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
bf30: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
bf40: 3a 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 : test " test-na
bf50: 6d 65 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 me " has listed
bf60: 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 itself as a wait
bf70: 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 on, please corre
bf80: 63 74 20 74 68 69 73 21 22 29 0a 09 20 20 20 20 ct this!")..
bf90: 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e 20 28 (set! waiton (
bfa0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
bfb0: 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 x)(not (equal? x
bfc0: 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 hed))) waitons)
bfd0: 29 29 29 0a 0a 09 28 63 6f 6e 64 20 0a 09 20 0a )))...(cond .. .
bfe0: 09 20 3b 3b 20 57 65 20 77 61 6e 74 20 74 6f 20 . ;; We want to
bff0: 63 61 74 63 68 20 74 65 73 74 73 20 74 68 61 74 catch tests that
c000: 20 68 61 76 65 20 77 61 69 74 6f 6e 73 20 74 68 have waitons th
c010: 61 74 20 61 72 65 20 4e 4f 54 20 69 6e 20 74 68 at are NOT in th
c020: 65 20 71 75 65 75 65 20 61 6e 64 20 64 69 73 63 e queue and disc
c030: 61 72 64 20 74 68 65 6d 20 49 46 46 20 0a 09 20 ard them IFF ..
c040: 3b 3b 20 74 68 65 79 20 68 61 76 65 20 62 65 65 ;; they have bee
c050: 6e 20 74 68 72 6f 75 67 68 20 74 68 65 20 77 72 n through the wr
c060: 69 6e 67 65 72 20 31 30 20 6f 72 20 6d 6f 72 65 inger 10 or more
c070: 20 74 69 6d 65 73 0a 09 20 28 28 61 6e 64 20 28 times.. ((and (
c080: 6c 69 73 74 3f 20 77 61 69 74 6f 6e 73 29 0a 09 list? waitons)..
c090: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c (not (nul
c0a0: 6c 3f 20 77 61 69 74 6f 6e 73 29 29 0a 09 20 20 l? waitons))..
c0b0: 20 20 20 20 20 28 3e 20 28 68 61 73 68 2d 74 61 (> (hash-ta
c0c0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
c0d0: 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 2a *max-tries-hash*
c0e0: 20 74 66 75 6c 6c 6e 61 6d 65 20 30 29 20 31 30 tfullname 0) 10
c0f0: 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 28 ).. (not (
c100: 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 0a 09 09 null? (filter...
c110: 09 20 20 20 20 6e 75 6d 62 65 72 3f 0a 09 09 09 . number?....
c120: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
c130: 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 09 20 20 (waiton).....
c140: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
c150: 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 61 member waiton ta
c160: 6c 29 29 20 20 20 20 20 20 20 20 20 20 20 20 3b l)) ;
c170: 3b 20 74 68 69 73 20 77 61 69 74 6f 6e 20 69 73 ; this waiton is
c180: 20 6e 6f 74 20 69 6e 20 74 68 65 20 6c 69 73 74 not in the list
c190: 20 74 6f 20 62 65 20 74 72 69 65 64 20 74 6f 20 to be tried to
c1a0: 72 75 6e 0a 09 09 09 09 09 20 20 20 20 28 6e 6f run...... (no
c1b0: 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e t (member waiton
c1c0: 20 72 65 72 75 6e 73 29 29 29 0a 09 09 09 09 20 reruns))).....
c1d0: 20 20 20 20 20 20 31 0a 09 09 09 09 20 20 20 20 1.....
c1e0: 20 20 20 23 66 29 29 0a 09 09 09 09 20 77 61 69 #f))..... wai
c1f0: 74 6f 6e 73 29 29 29 29 29 20 3b 3b 20 63 6f 75 tons))))) ;; cou
c200: 6c 64 20 64 6f 20 74 68 69 73 20 6d 6f 72 65 20 ld do this more
c210: 65 6c 65 67 61 6e 74 6c 79 20 77 69 74 68 20 61 elegantly with a
c220: 20 6d 61 72 6b 65 72 2e 2e 2e 2e 0a 09 20 20 28 marker...... (
c230: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
c240: 41 52 4e 49 4e 47 3a 20 4d 61 72 6b 69 6e 67 20 ARNING: Marking
c250: 74 65 73 74 20 22 20 74 66 75 6c 6c 6e 61 6d 65 test " tfullname
c260: 20 22 20 61 73 20 6e 6f 74 20 72 75 6e 6e 61 62 " as not runnab
c270: 6c 65 2e 20 49 74 20 69 73 20 77 61 69 74 69 6e le. It is waitin
c280: 67 20 6f 6e 20 74 65 73 74 73 20 74 68 61 74 20 g on tests that
c290: 63 61 6e 6e 6f 74 20 62 65 20 72 75 6e 2e 20 47 cannot be run. G
c2a0: 69 76 69 6e 67 20 75 70 20 6e 6f 77 2e 22 29 0a iving up now.").
c2b0: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
c2c0: 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
c2d0: 79 20 74 66 75 6c 6c 6e 61 6d 65 20 27 72 65 6d y tfullname 'rem
c2e0: 6f 76 65 64 29 29 0a 0a 09 20 3b 3b 20 69 74 65 oved))... ;; ite
c2f0: 6d 73 20 69 73 20 23 66 20 74 68 65 6e 20 74 68 ms is #f then th
c300: 65 20 74 65 73 74 20 69 73 20 6f 6b 20 74 6f 20 e test is ok to
c310: 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f be handed off to
c320: 20 6c 61 75 6e 63 68 20 28 62 75 74 20 6e 6f 74 launch (but not
c330: 20 62 65 66 6f 72 65 29 0a 09 20 3b 3b 20 0a 09 before).. ;; ..
c340: 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 0a 09 20 ((not items)..
c350: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
c360: 66 6f 20 34 20 22 4f 55 54 45 52 20 43 4f 4e 44 fo 4 "OUTER COND
c370: 3a 20 28 6e 6f 74 20 69 74 65 6d 73 29 22 29 0a : (not items)").
c380: 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 . (if (and (not
c390: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
c3a0: 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 3a st-patts (tests:
c3b0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
c3c0: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
c3d0: 72 64 29 20 69 74 65 6d 2d 70 61 74 68 20 72 65 rd) item-path re
c3e0: 71 75 69 72 65 64 3a 20 72 65 71 75 69 72 65 64 quired: required
c3f0: 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 28 6e -tests))... (n
c400: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 ot (null? tal)))
c410: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
c420: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
c430: 20 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 reg reruns))..
c440: 20 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 (let ((loop-lis
c450: 74 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 73 2d t (runs:process-
c460: 65 78 70 61 6e 64 65 64 2d 74 65 73 74 73 20 68 expanded-tests h
c470: 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e ed tal reg rerun
c480: 73 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c s reglen regfull
c490: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 72 75 6e test-record run
c4a0: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
c4b0: 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 6f 75 tem-path jobgrou
c4c0: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
c4d0: 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 -jobs run-id wai
c4e0: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 tons item-path t
c4f0: 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 61 74 estmode test-pat
c500: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test
c510: 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 s test-registry
c520: 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 20 66 registry-mutex f
c530: 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 72 75 6e lags keyvals run
c540: 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 6c 6c -info newtal all
c550: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
c560: 69 74 65 6d 6d 61 70 29 29 29 0a 09 20 20 20 20 itemmap)))..
c570: 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 20 28 61 (if loop-list (a
c580: 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c pply loop loop-l
c590: 69 73 74 29 29 29 29 0a 0a 09 20 3b 3b 20 69 74 ist))))... ;; it
c5a0: 65 6d 73 20 70 72 6f 63 65 73 73 65 64 20 69 6e ems processed in
c5b0: 74 6f 20 61 20 6c 69 73 74 20 62 75 74 20 6e 6f to a list but no
c5c0: 74 20 63 61 6d 65 20 69 6e 20 61 73 20 61 20 6c t came in as a l
c5d0: 69 73 74 20 62 65 65 6e 20 70 72 6f 63 65 73 73 ist been process
c5e0: 65 64 0a 09 20 3b 3b 0a 09 20 28 28 61 6e 64 20 ed.. ;;.. ((and
c5f0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 20 20 (list? items)
c600: 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b 6e 6f ;; thus we kno
c610: 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 65 20 w our items are
c620: 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c 61 74 already calculat
c630: 65 64 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 ed.. (not
c640: 20 20 69 74 65 6d 64 61 74 29 29 20 20 3b 3b 20 itemdat)) ;;
c650: 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 78 70 61 and not yet expa
c660: 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 20 6c 69 nded into the li
c670: 73 74 20 6f 66 20 74 68 69 6e 67 73 20 74 6f 20 st of things to
c680: 62 65 20 64 6f 6e 65 0a 09 20 20 28 64 65 62 75 be done.. (debu
c690: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
c6a0: 4f 55 54 45 52 20 43 4f 4e 44 3a 20 28 61 6e 64 OUTER COND: (and
c6b0: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6e (list? items)(n
c6c0: 6f 74 20 69 74 65 6d 64 61 74 29 29 22 29 0a 09 ot itemdat))")..
c6d0: 20 20 3b 3b 20 4d 75 73 74 20 64 65 74 65 72 6d ;; Must determ
c6e0: 69 6e 65 20 69 66 20 74 68 65 20 69 74 65 6d 73 ine if the items
c6f0: 20 6c 69 73 74 20 69 73 20 76 61 6c 69 64 2e 20 list is valid.
c700: 44 69 73 63 61 72 64 20 74 68 65 20 74 65 73 74 Discard the test
c710: 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a 09 if it is not...
c720: 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 (if (and (list
c730: 3f 20 69 74 65 6d 73 29 0a 09 09 20 20 20 28 3e ? items)... (>
c740: 20 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 29 20 (length items)
c750: 30 29 0a 09 09 20 20 20 28 61 6e 64 20 28 6c 69 0)... (and (li
c760: 73 74 3f 20 28 63 61 72 20 69 74 65 6d 73 29 29 st? (car items))
c770: 0a 09 09 09 28 3e 20 28 6c 65 6e 67 74 68 20 28 ....(> (length (
c780: 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 29 0a car items)) 0)).
c790: 09 09 20 20 20 28 64 65 62 75 67 3a 64 65 62 75 .. (debug:debu
c7a0: 67 2d 6d 6f 64 65 20 31 29 29 0a 09 20 20 20 20 g-mode 1))..
c7b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
c7c0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 (map (lambda (r
c7d0: 6f 77 29 0a 09 09 09 09 20 20 20 20 28 63 6f 6e ow)..... (con
c7e0: 63 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 c (string-inters
c7f0: 70 65 72 73 65 0a 09 09 09 09 09 20 20 20 28 6d perse...... (m
c800: 61 70 20 28 6c 61 6d 62 64 61 20 28 76 61 72 76 ap (lambda (varv
c810: 61 6c 29 0a 09 09 09 09 09 09 20 20 28 73 74 72 al)....... (str
c820: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
c830: 76 61 72 76 61 6c 20 22 3d 22 29 29 0a 09 09 09 varval "="))....
c840: 09 09 09 72 6f 77 29 0a 09 09 09 09 09 20 20 20 ...row)......
c850: 22 20 22 29 0a 09 09 09 09 09 20 20 22 5c 6e 22 " ")...... "\n"
c860: 29 29 0a 09 09 09 09 20 20 69 74 65 6d 73 29 29 ))..... items))
c870: 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 ).. (for-each..
c880: 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 79 2d 69 (lambda (my-i
c890: 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 28 6c temdat).. (l
c8a0: 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 72 et* ((new-test-r
c8b0: 65 63 6f 72 64 20 28 6c 65 74 20 28 28 6e 65 77 ecord (let ((new
c8c0: 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 74 73 3a rec (make-tests:
c8d0: 74 65 73 74 71 75 65 75 65 29 29 29 0a 09 09 09 testqueue)))....
c8e0: 09 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d . (vector-
c8f0: 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 6f 72 copy! test-recor
c900: 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 20 20 d newrec).....
c910: 20 20 20 20 20 6e 65 77 72 65 63 29 29 0a 09 09 newrec))...
c920: 20 20 20 20 28 6d 79 2d 69 74 65 6d 2d 70 61 74 (my-item-pat
c930: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
c940: 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 th my-itemdat)))
c950: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 74 65 .. (if (te
c960: 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 sts:match test-p
c970: 61 74 74 73 20 68 65 64 20 6d 79 2d 69 74 65 6d atts hed my-item
c980: 2d 70 61 74 68 20 72 65 71 75 69 72 65 64 3a 20 -path required:
c990: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 20 required-tests)
c9a0: 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 ;; (patt-list-ma
c9b0: 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 tch my-item-path
c9c0: 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 20 20 item-patts)
c9d0: 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 77 ;; yes, w
c9e0: 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 65 73 e want to proces
c9f0: 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e 4f 54 s this item, NOT
ca00: 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 6e 65 E: Should not ne
ca10: 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 68 65 ed this check he
ca20: 72 65 21 0a 09 09 20 20 20 28 6c 65 74 20 28 28 re!... (let ((
ca30: 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 64 62 3a newtestname (db:
ca40: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
ca50: 61 6d 65 20 68 65 64 20 6d 79 2d 69 74 65 6d 2d ame hed my-item-
ca60: 70 61 74 68 29 29 29 20 20 20 20 3b 3b 20 74 65 path))) ;; te
ca70: 73 74 20 6e 61 6d 65 73 20 61 72 65 20 75 6e 69 st names are uni
ca80: 71 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d 65 2f que on testname/
ca90: 69 74 65 6d 2d 70 61 74 68 0a 09 09 20 20 20 20 item-path...
caa0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
cab0: 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 20 20 20 e-set-items!
cac0: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
cad0: 20 23 66 29 0a 09 09 20 20 20 20 20 28 74 65 73 #f)... (tes
cae0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 ts:testqueue-set
caf0: 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 77 2d -itemdat! new-
cb00: 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d 69 test-record my-i
cb10: 74 65 6d 64 61 74 29 0a 09 09 20 20 20 20 20 28 temdat)... (
cb20: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
cb30: 73 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e set-item_path! n
cb40: 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d ew-test-record m
cb50: 79 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 y-item-path)...
cb60: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
cb70: 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 set! test-record
cb80: 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 6e 65 s newtestname ne
cb90: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 09 w-test-record)..
cba0: 09 20 20 20 20 20 28 73 65 74 21 20 74 61 6c 20 . (set! tal
cbb0: 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 (append tal (lis
cbc0: 74 20 6e 65 77 74 65 73 74 6e 61 6d 65 29 29 29 t newtestname)))
cbd0: 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 )))) ;; since th
cbe0: 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 ese are itemized
cbf0: 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 create new test
cc00: 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f names testname/
cc10: 69 74 65 6d 70 61 74 68 0a 09 20 20 20 69 74 65 itempath.. ite
cc20: 6d 73 29 0a 0a 09 20 20 3b 3b 20 28 64 65 62 75 ms)... ;; (debu
cc30: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
cc40: 54 65 73 74 20 22 20 28 74 65 73 74 73 3a 74 65 Test " (tests:te
cc50: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
cc60: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
cc70: 29 20 22 20 69 73 20 69 74 65 6d 69 7a 65 64 20 ) " is itemized
cc80: 62 75 74 20 68 61 73 20 6e 6f 20 69 74 65 6d 73 but has no items
cc90: 22 29 0a 0a 09 20 20 3b 3b 20 41 74 20 74 68 69 ")... ;; At thi
cca0: 73 20 70 6f 69 6e 74 20 77 65 20 68 61 76 65 20 s point we have
ccb0: 70 6f 73 73 69 62 6c 79 20 61 64 64 65 64 20 69 possibly added i
ccc0: 74 65 6d 73 20 74 6f 20 74 61 6c 20 62 75 74 20 tems to tal but
ccd0: 61 6c 6c 20 6d 75 73 74 20 62 65 20 68 61 6e 64 all must be hand
cce0: 65 64 20 6f 66 66 20 74 6f 20 0a 09 20 20 3b 3b ed off to .. ;;
ccf0: 20 49 4e 4e 45 52 20 43 4f 4e 44 20 6c 6f 67 69 INNER COND logi
cd00: 63 2e 20 49 20 74 68 69 6e 6b 20 6c 6f 6f 70 20 c. I think loop
cd10: 77 69 74 68 6f 75 74 20 72 6f 74 61 74 69 6e 67 without rotating
cd20: 20 74 68 65 20 71 75 65 75 65 20 0a 09 20 20 3b the queue .. ;
cd30: 3b 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 ; (loop hed tal
cd40: 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 20 reg reruns))..
cd50: 3b 3b 20 28 6c 65 74 20 28 28 6e 65 77 74 61 6c ;; (let ((newtal
cd60: 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 (append tal (li
cd70: 73 74 20 68 65 64 29 29 29 29 20 20 3b 3b 20 57 st hed)))) ;; W
cd80: 65 20 73 68 6f 75 6c 64 20 64 69 73 63 61 72 64 e should discard
cd90: 20 68 65 64 20 61 73 20 69 74 20 68 61 73 20 62 hed as it has b
cda0: 65 65 6e 20 65 78 70 61 6e 64 65 64 20 69 6e 74 een expanded int
cdb0: 6f 20 69 74 27 73 20 69 74 65 6d 73 3f 20 59 65 o it's items? Ye
cdc0: 73 2c 20 62 75 74 20 6f 6e 6c 79 20 69 66 20 74 s, but only if t
cdd0: 68 69 73 20 2a 69 73 2a 20 61 6e 20 69 74 65 6d his *is* an item
cde0: 69 7a 65 64 20 74 65 73 74 0a 09 20 20 3b 3b 20 ized test.. ;;
cdf0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
ce00: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
ce10: 65 67 20 72 65 72 75 6e 73 29 0a 09 20 20 28 69 eg reruns).. (i
ce20: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 f (null? tal)..
ce30: 20 20 20 20 20 23 66 0a 09 20 20 20 20 20 20 28 #f.. (
ce40: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
ce50: 64 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 dr tal) reg reru
ce60: 6e 73 29 29 29 0a 09 20 20 20 20 0a 09 20 3b 3b ns))).. .. ;;
ce70: 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 20 70 if items is a p
ce80: 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 74 6f roc then need to
ce90: 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 2d 69 run items:get-i
cea0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
ceb0: 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 20 61 , get the list a
cec0: 6e 64 20 6c 6f 6f 70 20 0a 09 20 3b 3b 20 20 20 nd loop .. ;;
ced0: 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 74 - but only do t
cee0: 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 73 hat if resources
cef0: 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 6f exist to kick o
cf00: 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 3b 3b 20 ff the job.. ;;
cf10: 45 58 50 41 4e 44 20 49 54 45 4d 53 0a 09 20 28 EXPAND ITEMS.. (
cf20: 28 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (or (procedure?
cf30: 69 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 items)(eq? items
cf40: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
cf50: 29 29 0a 09 20 20 28 6c 65 74 20 28 28 63 61 6e )).. (let ((can
cf60: 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 72 75 -run-more (ru
cf70: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
cf80: 74 65 73 74 73 20 72 75 6e 2d 69 64 20 6a 6f 62 tests run-id job
cf90: 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 group max-concur
cfa0: 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a 09 20 20 rent-jobs)))..
cfb0: 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 (if (and (list
cfc0: 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a ? can-run-more).
cfd0: 09 09 20 20 20 20 20 28 63 61 72 20 63 61 6e 2d .. (car can-
cfe0: 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 28 6c 65 run-more))...(le
cff0: 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 20 28 72 t ((loop-list (r
d000: 75 6e 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d 73 uns:expand-items
d010: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
d020: 75 6e 73 20 72 65 67 66 75 6c 6c 20 6e 65 77 74 uns regfull newt
d030: 61 6c 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d al jobgroup max-
d040: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
d050: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 run-id waitons i
d060: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f 64 tem-path testmod
d070: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 63 61 e test-record ca
d080: 6e 2d 72 75 6e 2d 6d 6f 72 65 20 69 74 65 6d 73 n-run-more items
d090: 20 72 75 6e 6e 61 6d 65 20 74 63 6f 6e 66 69 67 runname tconfig
d0a0: 20 72 65 67 6c 65 6e 20 74 65 73 74 2d 72 65 67 reglen test-reg
d0b0: 69 73 74 72 79 20 74 65 73 74 2d 72 65 63 6f 72 istry test-recor
d0c0: 64 73 20 69 74 65 6d 6d 61 70 29 29 29 0a 09 09 ds itemmap)))...
d0d0: 20 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 0a (if loop-list.
d0e0: 09 09 20 20 20 20 20 20 28 61 70 70 6c 79 20 6c .. (apply l
d0f0: 6f 6f 70 20 6c 6f 6f 70 2d 6c 69 73 74 29 29 29 oop loop-list)))
d100: 0a 09 09 3b 3b 20 69 66 20 63 61 6e 27 74 20 72 ...;; if can't r
d110: 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 6c 6f 6f un more just loo
d120: 70 20 77 69 74 68 20 6e 65 78 74 20 70 6f 73 73 p with next poss
d130: 69 62 6c 65 20 74 65 73 74 0a 09 09 28 6c 6f 6f ible test...(loo
d140: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
d150: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 dr newtal) reg r
d160: 65 72 75 6e 73 29 29 29 29 0a 09 20 20 20 20 0a eruns)))).. .
d170: 09 20 3b 3b 20 74 68 69 73 20 63 61 73 65 20 73 . ;; this case s
d180: 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 70 65 6e hould not happen
d190: 2c 20 61 64 64 65 64 20 74 6f 20 68 65 6c 70 20 , added to help
d1a0: 63 61 74 63 68 20 61 6e 79 20 62 75 67 73 0a 09 catch any bugs..
d1b0: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 ((and (list? it
d1c0: 65 6d 73 29 20 69 74 65 6d 64 61 74 29 0a 09 20 ems) itemdat)..
d1d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
d1e0: 22 45 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e "ERROR: Should n
d1f0: 6f 74 20 68 61 76 65 20 61 20 6c 69 73 74 20 6f ot have a list o
d200: 66 20 69 74 65 6d 73 20 69 6e 20 61 20 74 65 73 f items in a tes
d210: 74 20 61 6e 64 20 74 68 65 20 69 74 65 6d 73 70 t and the itemsp
d220: 61 74 68 20 73 65 74 20 2d 20 70 6c 65 61 73 65 ath set - please
d230: 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 report this")..
d240: 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 28 28 (exit 1)).. ((
d250: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e not (null? rerun
d260: 73 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 6e s)).. (let* ((n
d270: 65 77 6c 73 74 20 28 74 65 73 74 73 3a 66 69 6c ewlst (tests:fil
d280: 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 ter-non-runnable
d290: 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 74 run-id tal test
d2a0: 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 69 2e -records)) ;; i.
d2b0: 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 41 49 e. not FAIL, WAI
d2c0: 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 2c VED, INCOMPLETE,
d2d0: 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a 09 PASS, KILLED,..
d2e0: 09 20 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d . (junked (lset-
d2f0: 64 69 66 66 65 72 65 6e 63 65 20 65 71 75 61 6c difference equal
d300: 3f 20 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a ? tal newlst))).
d310: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
d320: 74 2d 69 6e 66 6f 20 34 20 22 66 75 6c 6c 20 64 t-info 4 "full d
d330: 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 69 66 20 rop through, if
d340: 72 65 72 75 6e 73 20 69 73 20 6c 65 73 73 20 74 reruns is less t
d350: 68 61 6e 20 31 30 30 20 77 65 20 77 69 6c 6c 20 han 100 we will
d360: 66 6f 72 63 65 20 72 65 74 72 79 20 74 68 65 6d force retry them
d370: 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e , reruns=" rerun
d380: 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c 29 0a s ", tal=" tal).
d390: 09 20 20 20 20 28 69 66 20 28 3c 20 6e 75 6d 2d . (if (< num-
d3a0: 72 65 74 72 69 65 73 20 6d 61 78 2d 72 65 74 72 retries max-retr
d3b0: 69 65 73 29 0a 09 09 28 73 65 74 21 20 6e 65 77 ies)...(set! new
d3c0: 6c 73 74 20 28 61 70 70 65 6e 64 20 72 65 72 75 lst (append reru
d3d0: 6e 73 20 6e 65 77 6c 73 74 29 29 29 0a 09 20 20 ns newlst)))..
d3e0: 20 20 28 73 65 74 21 20 6e 75 6d 2d 72 65 74 72 (set! num-retr
d3f0: 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 72 69 ies (+ num-retri
d400: 65 73 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 28 es 1)).. ;; (
d410: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b thread-sleep! (+
d420: 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 1 *global-delta
d430: 2a 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f *)).. (if (no
d440: 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 29 t (null? newlst)
d450: 29 0a 09 09 3b 3b 20 73 69 6e 63 65 20 72 65 72 )...;; since rer
d460: 75 6e 73 20 68 61 76 65 20 62 65 65 6e 20 74 61 uns have been ta
d470: 63 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 cked on to newls
d480: 74 20 63 72 65 61 74 65 20 6e 65 77 20 72 65 72 t create new rer
d490: 75 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a uns from junked.
d4a0: 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 ..(loop (car new
d4b0: 6c 73 74 29 28 63 64 72 20 6e 65 77 6c 73 74 29 lst)(cdr newlst)
d4c0: 20 72 65 67 20 28 64 65 6c 65 74 65 2d 64 75 70 reg (delete-dup
d4d0: 6c 69 63 61 74 65 73 20 6a 75 6e 6b 65 64 29 29 licates junked))
d4e0: 29 29 29 0a 09 20 28 28 6e 6f 74 20 28 6e 75 6c ))).. ((not (nul
d4f0: 6c 3f 20 74 61 6c 29 29 0a 09 20 20 28 64 65 62 l? tal)).. (deb
d500: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
d510: 22 49 27 6d 20 70 72 65 74 74 79 20 73 75 72 65 "I'm pretty sure
d520: 20 49 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 I shouldn't get
d530: 20 68 65 72 65 2e 22 29 29 0a 09 20 28 28 6e 6f here.")).. ((no
d540: 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 20 3b t (null? reg)) ;
d550: 3b 20 63 6f 75 6c 64 20 77 65 20 67 65 74 20 68 ; could we get h
d560: 65 72 65 20 77 69 74 68 20 6c 65 66 74 6f 76 65 ere with leftove
d570: 72 73 3f 0a 09 20 20 28 64 65 62 75 67 3a 70 72 rs?.. (debug:pr
d580: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 48 61 76 65 int-info 0 "Have
d590: 20 6c 65 66 74 6f 76 65 72 73 21 22 29 0a 09 20 leftovers!")..
d5a0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 67 29 (loop (car reg)
d5b0: 28 63 64 72 20 72 65 67 29 20 27 28 29 20 72 65 (cdr reg) '() re
d5c0: 72 75 6e 73 29 29 0a 09 20 28 65 6c 73 65 0a 09 runs)).. (else..
d5d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
d5e0: 6e 66 6f 20 34 20 22 45 78 69 74 69 6e 67 20 6c nfo 4 "Exiting l
d5f0: 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 68 oop with...\n h
d600: 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 61 ed=" hed "\n ta
d610: 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 20 72 65 72 l=" tal "\n rer
d620: 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 uns=" reruns))..
d630: 20 29 29 29 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 ))). ;; now
d640: 2a 69 66 2a 20 2d 72 75 6e 2d 77 61 69 74 20 77 *if* -run-wait w
d650: 65 20 77 61 69 74 20 66 6f 72 20 61 6c 6c 20 74 e wait for all t
d660: 65 73 74 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a ests to be done.
d670: 20 20 20 20 3b 3b 20 4e 6f 77 20 77 61 69 74 20 ;; Now wait
d680: 66 6f 72 20 61 6e 79 20 52 55 4e 4e 49 4e 47 20 for any RUNNING
d690: 74 65 73 74 73 20 74 6f 20 63 6f 6d 70 6c 65 74 tests to complet
d6a0: 65 20 28 69 66 20 69 6e 20 72 75 6e 2d 77 61 69 e (if in run-wai
d6b0: 74 20 6d 6f 64 65 29 0a 20 20 20 20 28 6c 65 74 t mode). (let
d6c0: 20 77 61 69 74 2d 6c 6f 6f 70 20 28 28 6e 75 6d wait-loop ((num
d6d0: 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 28 72 -running (r
d6e0: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
d6f0: 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 ts-running-for-r
d700: 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 un-id run-id))..
d710: 09 20 20 20 20 28 70 72 65 76 2d 6e 75 6d 2d 72 . (prev-num-r
d720: 75 6e 6e 69 6e 67 20 30 29 29 0a 20 20 20 20 20 unning 0)).
d730: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
d740: 20 30 20 22 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3d 0 "num-running=
d750: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 22 2c " num-running ",
d760: 20 70 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e prev-num-runnin
d770: 67 3d 22 20 70 72 65 76 2d 6e 75 6d 2d 72 75 6e g=" prev-num-run
d780: 6e 69 6e 67 29 0a 20 20 20 20 20 20 28 69 66 20 ning). (if
d790: 28 61 6e 64 20 28 6f 72 20 28 61 72 67 73 3a 67 (and (or (args:g
d7a0: 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 77 61 69 et-arg "-run-wai
d7b0: 74 22 29 0a 09 09 20 20 20 28 65 71 75 61 6c 3f t")... (equal?
d7c0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
d7d0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
d7e0: 74 75 70 22 20 22 72 75 6e 2d 77 61 69 74 22 29 tup" "run-wait")
d7f0: 20 22 79 65 73 22 29 29 0a 09 20 20 20 20 20 20 "yes"))..
d800: 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 (> num-running
d810: 30 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 0)).. (begin..
d820: 20 20 20 3b 3b 20 48 65 72 65 20 77 65 20 6d 61 ;; Here we ma
d830: 72 6b 20 61 6e 79 20 6f 6c 64 20 64 65 66 75 6e rk any old defun
d840: 63 74 20 74 65 73 74 73 20 61 73 20 69 6e 63 6f ct tests as inco
d850: 6d 70 6c 65 74 65 2e 20 44 6f 20 74 68 69 73 20 mplete. Do this
d860: 65 76 65 72 79 20 66 69 66 74 65 65 6e 20 6d 69 every fifteen mi
d870: 6e 75 74 65 73 0a 09 20 20 20 20 3b 3b 20 28 64 nutes.. ;; (d
d880: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 47 6f ebug:print 0 "Go
d890: 74 20 68 65 72 65 20 65 68 21 20 6e 75 6d 2d 72 t here eh! num-r
d8a0: 75 6e 6e 69 6e 67 3d 22 20 6e 75 6d 2d 72 75 6e unning=" num-run
d8b0: 6e 69 6e 67 20 22 20 28 3e 20 6e 75 6d 2d 72 75 ning " (> num-ru
d8c0: 6e 6e 69 6e 67 20 30 29 20 22 20 28 3e 20 6e 75 nning 0) " (> nu
d8d0: 6d 2d 72 75 6e 6e 69 6e 67 20 30 29 29 0a 09 20 m-running 0))..
d8e0: 20 20 20 28 69 66 20 28 3e 20 28 63 75 72 72 65 (if (> (curre
d8f0: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 6c 61 nt-seconds)(+ la
d900: 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 st-time-incomple
d910: 74 65 20 39 30 30 29 29 0a 09 09 28 62 65 67 69 te 900))...(begi
d920: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
d930: 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 72 6b 69 nt-info 0 "Marki
d940: 6e 67 20 73 74 75 63 6b 20 74 65 73 74 73 20 61 ng stuck tests a
d950: 73 20 49 4e 43 4f 4d 50 4c 45 54 45 20 77 68 69 s INCOMPLETE whi
d960: 6c 65 20 77 61 69 74 69 6e 67 20 66 6f 72 20 72 le waiting for r
d970: 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 2e 20 52 un " run-id ". R
d980: 75 6e 6e 69 6e 67 20 61 73 20 70 69 64 20 22 20 unning as pid "
d990: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
d9a0: 2d 69 64 29 20 22 20 6f 6e 20 22 20 28 67 65 74 -id) " on " (get
d9b0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 09 20 -host-name))...
d9c0: 20 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 (set! last-time
d9d0: 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 28 63 75 72 -incomplete (cur
d9e0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
d9f0: 09 20 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 . (rmt:find-and
da00: 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 -mark-incomplete
da10: 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 09 20 run-id #f)))..
da20: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f (if (not (eq?
da30: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 70 72 65 num-running pre
da40: 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a v-num-running)).
da50: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
da60: 6e 66 6f 20 30 20 22 72 75 6e 2d 77 61 69 74 20 nfo 0 "run-wait
da70: 73 70 65 63 69 66 69 65 64 2c 20 77 61 69 74 69 specified, waiti
da80: 6e 67 20 6f 6e 20 22 20 6e 75 6d 2d 72 75 6e 6e ng on " num-runn
da90: 69 6e 67 20 22 20 74 65 73 74 73 20 69 6e 20 52 ing " tests in R
daa0: 55 4e 4e 49 4e 47 2c 20 52 45 4d 4f 54 45 48 4f UNNING, REMOTEHO
dab0: 53 54 53 54 41 52 54 20 6f 72 20 4c 41 55 4e 43 STSTART or LAUNC
dac0: 48 45 44 20 73 74 61 74 65 20 61 74 20 22 20 28 HED state at " (
dad0: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 time->string (se
dae0: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
daf0: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
db00: 64 73 29 29 29 29 29 0a 09 20 20 20 20 28 74 68 ds))))).. (th
db10: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 read-sleep! 5)..
db20: 20 20 20 20 3b 3b 20 28 77 61 69 74 2d 6c 6f 6f ;; (wait-loo
db30: 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 p (rmt:get-count
db40: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
db50: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
db60: 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 ) num-running)))
db70: 29 0a 09 20 20 20 20 28 77 61 69 74 2d 6c 6f 6f ).. (wait-loo
db80: 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 p (rmt:get-count
db90: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
dba0: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
dbb0: 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 ) num-running)))
dbc0: 29 0a 20 20 20 20 3b 3b 20 4c 45 54 2a 20 28 28 ). ;; LET* ((
dbd0: 74 65 73 74 2d 72 65 63 6f 72 64 0a 20 20 20 20 test-record.
dbe0: 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 20 6f ;; we get here o
dbf0: 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 68 22 n "drop through"
dc00: 2e 20 41 6c 6c 20 64 6f 6e 65 21 0a 20 20 20 20 . All done!.
dc10: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
dc20: 6f 20 31 20 22 41 6c 6c 20 74 65 73 74 73 20 6c o 1 "All tests l
dc30: 61 75 6e 63 68 65 64 22 29 29 29 0a 0a 28 64 65 aunched")))..(de
dc40: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
dc50: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
dc60: 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 t-met). (filter
dc70: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
dc80: 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 6f . (and (vecto
dc90: 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 20 r? test) ;; not
dca0: 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 0a (string? test)).
dcb0: 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 .. (equal? (db:t
dcc0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 est-get-state te
dcd0: 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 st) "COMPLETED")
dce0: 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ... (not (member
dcf0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
dd00: 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 20 atus test)....
dd10: 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 41 '("PASS" "WA
dd20: 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 RN" "CHECK" "WAI
dd30: 56 45 44 22 20 22 53 4b 49 50 22 29 29 29 29 29 VED" "SKIP")))))
dd40: 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d .. prereqs-not-
dd50: 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 met))..(define (
dd60: 72 75 6e 73 3a 63 61 6c 63 2d 70 72 65 72 65 71 runs:calc-prereq
dd70: 2d 66 61 69 6c 20 70 72 65 72 65 71 73 2d 6e 6f -fail prereqs-no
dd80: 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 t-met). (filter
dd90: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
dda0: 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 6f . (and (vecto
ddb0: 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 20 r? test) ;; not
ddc0: 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 0a (string? test)).
ddd0: 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 .. (equal? (db:t
dde0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 est-get-state te
ddf0: 73 74 29 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 st) "NOT_STARTED
de00: 22 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 ")... (not (memb
de10: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
de20: 73 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 status test)....
de30: 20 20 20 20 20 20 27 28 22 6e 2f 61 22 20 22 4b '("n/a" "K
de40: 45 45 50 5f 54 52 59 49 4e 47 22 29 29 29 29 29 EEP_TRYING")))))
de50: 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d .. prereqs-not-
de60: 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 met))..(define (
de70: 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f runs:calc-not-co
de80: 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d mpleted prereqs-
de90: 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 not-met). (filt
dea0: 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 74 er. (lambda (t
deb0: 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 ). (or (not
dec0: 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 28 (vector? t)).. (
ded0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f 4d not (equal? "COM
dee0: 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 74 PLETED" (db:test
def0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 29 -get-state t))))
df00: 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ). prereqs-not
df10: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
df20: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
df30: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
df40: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
df50: 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ter. (lambda (
df60: 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 t). (or (not
df70: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
df80: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f (not (equal? "CO
df90: 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 MPLETED" (db:tes
dfa0: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 t-get-state t)))
dfb0: 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f )). prereqs-no
dfc0: 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 t-met))..(define
dfd0: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 72 75 6e 6e (runs:calc-runn
dfe0: 61 62 6c 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 able prereqs-not
dff0: 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 20 -met). (filter
e000: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 74 29 0a . (lambda (t).
e010: 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 (or (not (v
e020: 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 28 61 6e ector? t)).. (an
e030: 64 20 28 65 71 75 61 6c 3f 20 22 4e 4f 54 5f 53 d (equal? "NOT_S
e040: 54 41 52 54 45 44 22 20 28 64 62 3a 74 65 73 74 TARTED" (db:test
e050: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 0a 09 -get-state t))..
e060: 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 64 (member (d
e070: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
e080: 73 20 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 s t).... '(
e090: 22 6e 2f 61 22 20 22 4b 45 45 50 5f 54 52 59 49 "n/a" "KEEP_TRYI
e0a0: 4e 47 22 29 29 29 29 29 0a 20 20 20 70 72 65 72 NG"))))). prer
e0b0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
e0c0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 65 define (runs:pre
e0d0: 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 0a tty-string lst).
e0e0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
e0f0: 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 76 t).. (if (not (v
e100: 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 20 ector? t))..
e110: 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 20 (conc t)..
e120: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
e130: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 et-testname t) "
e140: 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d :" (db:test-get-
e150: 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 state t) "/" (db
e160: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
e170: 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c 73 t)))). ls
e180: 74 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 t))..;; parent-t
e190: 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 20 est is there as
e1a0: 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f a placeholder fo
e1b0: 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 r when parent-te
e1c0: 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 sts can be run a
e1d0: 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 s a setup step.(
e1e0: 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 define (run:test
e1f0: 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f run-id run-info
e200: 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 keyvals runname
e210: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 test-record fla
e220: 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 20 74 gs parent-test t
e230: 65 73 74 2d 72 65 67 69 73 74 72 79 20 61 6c 6c est-registry all
e240: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 -tests-registry)
e250: 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 . ;; All these
e260: 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 vars might be re
e270: 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 ferenced by the
e280: 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 testconfig file
e290: 72 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 reader. (let* (
e2a0: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 (test-name (t
e2b0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
e2c0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 et-testname te
e2d0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 st-record)).. (t
e2e0: 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 est-waitons (tes
e2f0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
e300: 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 -waitons test
e310: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 -record)).. (tes
e320: 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 t-conf (tests
e330: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
e340: 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 estconfig test-r
e350: 65 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 ecord)).. (itemd
e360: 61 74 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 at (tests:t
e370: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
e380: 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 mdat test-rec
e390: 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 ord)).. (test-pa
e3a0: 74 68 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c th (hash-tabl
e3b0: 65 2d 72 65 66 20 61 6c 6c 2d 74 65 73 74 73 2d e-ref all-tests-
e3c0: 72 65 67 69 73 74 72 79 20 74 65 73 74 2d 6e 61 registry test-na
e3d0: 6d 65 29 29 20 3b 3b 20 28 63 6f 6e 63 20 2a 74 me)) ;; (conc *t
e3e0: 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f oppath* "/tests/
e3f0: 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b " test-name)) ;;
e400: 20 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 could use tests
e410: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
e420: 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 here ..... (forc
e430: 65 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 e (hash-t
e440: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
e450: 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 flags "-force"
e460: 23 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 #f)).. (rerun
e470: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
e480: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 -ref/default fla
e490: 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 gs "-rerun" #f))
e4a0: 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 .. (keepgoing
e4b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
e4c0: 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 /default flags "
e4d0: 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 -keepgoing" #f))
e4e0: 0a 09 20 28 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 .. (incomplete-t
e4f0: 69 6d 65 6f 75 74 20 28 73 74 72 69 6e 67 2d 3e imeout (string->
e500: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
e510: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
e520: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
e530: 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 6f incomplete-timeo
e540: 75 74 22 29 20 22 78 22 29 29 29 0a 09 20 28 69 ut") "x"))).. (i
e550: 74 65 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 tem-path "")
e560: 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 .. (db
e570: 20 23 66 29 0a 09 20 28 66 75 6c 6c 2d 74 65 73 #f).. (full-tes
e580: 74 2d 6e 61 6d 65 20 23 66 29 29 0a 0a 20 20 20 t-name #f))..
e590: 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 65 6d ;; setting item
e5a0: 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 69 66 dat to a list if
e5b0: 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 28 69 it is #f. (i
e5c0: 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 f (not itemdat)(
e5d0: 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 28 29 set! itemdat '()
e5e0: 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 74 65 )). (set! ite
e5f0: 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 m-path (item-lis
e600: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
e610: 29 0a 20 20 20 20 28 73 65 74 21 20 66 75 6c 6c ). (set! full
e620: 2d 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 -test-name (db:t
e630: 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 est-make-full-na
e640: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
e650: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 64 65 m-path)). (de
e660: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
e670: 0a 09 09 20 20 20 20 20 20 22 5c 6e 54 45 53 54 ... "\nTEST
e680: 4e 41 4d 45 3a 20 22 20 66 75 6c 6c 2d 74 65 73 NAME: " full-tes
e690: 74 2d 6e 61 6d 65 20 0a 09 09 20 20 20 20 20 20 t-name ...
e6a0: 22 5c 6e 20 20 20 74 65 73 74 2d 63 6f 6e 66 69 "\n test-confi
e6b0: 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 g: " (hash-table
e6c0: 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e ->alist test-con
e6d0: 66 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 20 f)... "\n
e6e0: 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d itemdat: " item
e6f0: 64 61 74 0a 09 09 20 20 20 20 20 20 29 0a 20 20 dat... ).
e700: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
e710: 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "Attempting to
e720: 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 66 75 launch test " fu
e730: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 ll-test-name).
e740: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE
e750: 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 ST_NAME" test-na
e760: 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 me) ;; . (set
e770: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
e780: 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 " item-path).
e790: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
e7a0: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
e7b0: 29 0a 20 20 20 20 28 72 75 6e 73 3a 73 65 74 2d ). (runs:set-
e7c0: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
e7d0: 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e 61 s run-id inrunna
e7e0: 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 me: runname) ;;
e7f0: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
e800: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
e810: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 hing process.
e820: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
e830: 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 ry *toppath*)..
e840: 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 ;; Here is wh
e850: 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ere the test_met
e860: 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 a table is best
e870: 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 updated. ;; Y
e880: 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 es, another use
e890: 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 of a global for
e8a0: 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 caching. Need a
e8b0: 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 better way?.
e8c0: 3b 3b 0a 20 20 20 20 3b 3b 20 54 68 65 72 65 20 ;;. ;; There
e8d0: 69 73 20 6e 6f 77 20 61 20 73 69 6e 67 6c 65 20 is now a single
e8e0: 63 61 6c 6c 20 74 6f 20 72 75 6e 73 3a 75 70 64 call to runs:upd
e8f0: 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 ate-all-test_met
e900: 61 20 61 6e 64 20 74 68 69 73 20 0a 20 20 20 20 a and this .
e910: 3b 3b 20 70 65 72 2d 74 65 73 74 20 63 61 6c 6c ;; per-test call
e920: 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 2e 20 is not needed.
e930: 47 69 76 65 6e 20 74 68 65 20 64 65 6c 69 63 61 Given the delica
e940: 63 79 20 6f 66 20 74 68 65 20 6d 6f 76 65 20 74 cy of the move t
e950: 6f 20 0a 20 20 20 20 3b 3b 20 76 31 2e 35 35 20 o . ;; v1.55
e960: 74 68 69 73 20 63 6f 64 65 20 69 73 20 62 65 69 this code is bei
e970: 6e 67 20 6c 65 66 74 20 69 6e 20 70 6c 61 63 65 ng left in place
e980: 20 66 6f 72 20 74 68 65 20 74 69 6d 65 20 62 65 for the time be
e990: 69 6e 67 2e 0a 20 20 20 20 3b 3b 0a 20 20 20 20 ing.. ;;.
e9a0: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
e9b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
e9c0: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
e9d0: 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 ted* test-name #
e9e0: 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 f)). (beg
e9f0: 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 in.. (hash-tab
ea00: 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 le-set! *test-me
ea10: 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 ta-updated* test
ea20: 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 -name #t).
ea30: 20 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 (runs:updat
ea40: 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 e-test_meta test
ea50: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
ea60: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 )). . ;; i
ea70: 74 65 6d 64 61 74 20 3d 3e 20 28 28 72 69 70 65 temdat => ((ripe
ea80: 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 ness "overripe")
ea90: 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 (temperature "c
eaa0: 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 ool") (season "s
eab0: 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 ummer")). (le
eac0: 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 t* ((new-test-pa
ead0: 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 th (string-inter
eae0: 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 sperse (cons tes
eaf0: 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 t-path (map cadr
eb00: 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 itemdat)) "/"))
eb10: 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
eb20: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
eb30: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
eb40: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
eb50: 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 20 ).. (testdat
eb60: 20 20 20 20 20 28 69 66 20 74 65 73 74 2d 69 64 (if test-id
eb70: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
eb80: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
eb90: 20 74 65 73 74 2d 69 64 29 20 23 66 29 29 29 0a test-id) #f))).
eba0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 (if (not t
ebb0: 65 73 74 64 61 74 29 0a 09 20 20 28 6c 65 74 20 estdat).. (let
ebc0: 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b 20 loop ().. ;;
ebd0: 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 ensure that the
ebe0: 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 6f path exists befo
ebf0: 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 re registering t
ec00: 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 he test.. ;;
ec10: 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f NOPE: Cannot! Do
ec20: 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 n't know yet whi
ec30: 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c ch disk area wil
ec40: 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e l be assigned...
ec50: 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 ... ;; (syste
ec60: 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d m (conc "mkdir -
ec70: 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 p " new-test-pat
ec80: 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 h)).. ;;..
ec90: 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; (open-run-cl
eca0: 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 ose tests:regist
ecb0: 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 er-test db run-i
ecc0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
ecd0: 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 -path).. ;;..
ece0: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 ;; NB// for
ecf0: 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 the above line.
ed00: 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 I want the test
ed10: 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 64 to be registered
ed20: 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 long before thi
ed30: 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 s routine gets c
ed40: 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 alled!.. ;;..
ed50: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 (if (not tes
ed60: 74 2d 69 64 29 28 73 65 74 21 20 74 65 73 74 2d t-id)(set! test-
ed70: 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 id (rmt:get-test
ed80: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
ed90: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
eda0: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
edb0: 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 69 test-id)...(begi
edc0: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
edd0: 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 74 nt 2 "WARN: Test
ede0: 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 64 not pre-created
edf0: 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 ? test-name=" te
ee00: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
ee10: 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 path=" item-path
ee20: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
ee30: 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a 67 65 -id)... (rmt:ge
ee40: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 neral-call 'regi
ee50: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
ee60: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
ee70: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 e item-path)...
ee80: 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 (set! test-id (
ee90: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 rmt:get-test-id
eea0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
eeb0: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 item-path))))..
eec0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
eed0: 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 64 -info 4 "test-id
eee0: 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 72 75 =" test-id ", ru
eef0: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c n-id=" run-id ",
ef00: 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 test-name=" tes
ef10: 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 t-name ", item-p
ef20: 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 74 ath=\"" item-pat
ef30: 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 73 65 h "\"").. (se
ef40: 74 21 20 74 65 73 74 64 61 74 20 28 72 6d 74 3a t! testdat (rmt:
ef50: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
ef60: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
ef70: 69 64 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e id)).. (if (n
ef80: 6f 74 20 74 65 73 74 64 61 74 29 0a 09 09 28 62 ot testdat)...(b
ef90: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
efa0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 41 print-info 0 "WA
efb0: 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 69 73 RNING: server is
efc0: 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 74 72 79 overloaded, try
efd0: 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 6f 6e 65 ing again in one
efe0: 20 73 65 63 6f 6e 64 22 29 0a 09 09 20 20 28 74 second")... (t
eff0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
f000: 09 09 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a 20 .. (loop))))).
f010: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
f020: 73 74 64 61 74 29 20 3b 3b 20 73 68 6f 75 6c 64 stdat) ;; should
f030: 20 4e 4f 54 20 68 61 70 70 65 6e 0a 09 20 20 28 NOT happen.. (
f040: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
f050: 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 RROR: failed to
f060: 67 65 74 20 74 65 73 74 20 72 65 63 6f 72 64 20 get test record
f070: 66 6f 72 20 74 65 73 74 2d 69 64 20 22 20 74 65 for test-id " te
f080: 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 73 st-id)). (s
f090: 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a et! test-id (db:
f0a0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
f0b0: 64 61 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 dat)). (if
f0c0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
f0d0: 73 74 2d 70 61 74 68 29 0a 09 20 20 28 63 68 61 st-path).. (cha
f0e0: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 nge-directory te
f0f0: 73 74 2d 70 61 74 68 29 0a 09 20 20 28 62 65 67 st-path).. (beg
f100: 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 in.. (debug:p
f110: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 65 73 rint "ERROR: tes
f120: 74 20 72 75 6e 20 70 61 74 68 20 6e 6f 74 20 63 t run path not c
f130: 72 65 61 74 65 64 20 62 65 66 6f 72 65 20 61 74 reated before at
f140: 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 75 6e 20 tempting to run
f150: 74 68 65 20 74 65 73 74 2e 20 50 65 72 68 61 70 the test. Perhap
f160: 73 20 79 6f 75 20 61 72 65 20 72 75 6e 6e 69 6e s you are runnin
f170: 67 20 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 20 61 g -remove-runs a
f180: 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 3f t the same time?
f190: 22 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 2d ").. (change-
f1a0: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
f1b0: 74 68 2a 29 29 29 0a 20 20 20 20 20 20 28 63 61 th*))). (ca
f1c0: 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 se (if force ;;
f1d0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
f1e0: 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 force")...'NOT_S
f1f0: 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 TARTED...(if tes
f200: 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 tdat... (stri
f210: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 ng->symbol (test
f220: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
f230: 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c at))... 'fail
f240: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 ed-to-insert))..
f250: 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 ((failed-to-inse
f260: 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 rt).. (debug:pri
f270: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
f280: 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 led to insert th
f290: 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 e record into th
f2a0: 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 e db"))..((NOT_S
f2b0: 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 TARTED COMPLETED
f2c0: 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 DELETED).. (let
f2d0: 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a ((runflag #f)).
f2e0: 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b . (cond.. ;
f2f0: 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f ; -force, run no
f300: 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 matter what..
f310: 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 (force (set! r
f320: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
f330: 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c ;; NOT_STARTED,
f340: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
f350: 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 hat.. ((membe
f360: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
f370: 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 45 e testdat) '("DE
f380: 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 LETED" "NOT_STAR
f390: 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e 66 TED"))(set! runf
f3a0: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
f3b0: 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 not -rerun and
f3c0: 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 PASS, WARN or CH
f3d0: 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 ECK, do no run..
f3e0: 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e ((and (or (n
f3f0: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 ot rerun)...
f400: 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 keepgoing)...
f410: 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 ;; Require to f
f420: 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 orce re-run for
f430: 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e COMPLETED or *an
f440: 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 ything* + PASS,W
f450: 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 ARN or CHECK...
f460: 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 (or (member (te
f470: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
f480: 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 stdat) '("PASS"
f490: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 "WARN" "CHECK" "
f4a0: 53 4b 49 50 22 20 22 57 41 49 56 45 44 22 29 29 SKIP" "WAIVED"))
f4b0: 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
f4c0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
f4d0: 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 4f testdat) '("CO
f4e0: 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 MPLETED")))) ..
f4f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f500: 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 -info 2 "running
f510: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
f520: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 e "/" item-path
f530: 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 20 " suppressed as
f540: 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 it is " (test:ge
f550: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
f560: 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 " and " (test:g
f570: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
f580: 74 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d t)).. (hash-
f590: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
f5a0: 72 65 67 69 73 74 72 79 20 66 75 6c 6c 2d 74 65 registry full-te
f5b0: 73 74 2d 6e 61 6d 65 20 27 44 4f 4e 4f 54 52 55 st-name 'DONOTRU
f5c0: 4e 29 20 3b 3b 20 43 4f 4d 50 4c 45 54 45 44 29 N) ;; COMPLETED)
f5d0: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
f5e0: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b flag #f)).. ;
f5f0: 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 ; -rerun and sta
f600: 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 tus is one of th
f610: 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 e specifed, run
f620: 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 it.. ((and re
f630: 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 run... (let* ((
f640: 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 rerunlst (stri
f650: 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 ng-split rerun "
f660: 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 ,")).... (must-r
f670: 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 erun (member (te
f680: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
f690: 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 stdat) rerunlst)
f6a0: 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a ))... (debug:
f6b0: 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d 72 print-info 3 "-r
f6c0: 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 erun list: " rer
f6d0: 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 un ", test-statu
f6e0: 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 s: " (test:get-s
f6f0: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 22 2c tatus testdat)",
f700: 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d must-rerun: " m
f710: 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 ust-rerun)...
f720: 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 must-rerun))..
f730: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f740: 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 66 -info 2 "Rerun f
f750: 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 orced for test "
f760: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
f770: 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 tem-path)..
f780: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
f790: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 )).. ;; -keep
f7a0: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
f7b0: 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 run FAIL.. ((
f7c0: 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 and keepgoing...
f7d0: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
f7e0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
f7f0: 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a at) '("FAIL"))).
f800: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
f810: 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 lag #f)).. ((
f820: 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a and (not rerun).
f830: 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 .. (member (tes
f840: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
f850: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
f860: 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 n/a"))).. (s
f870: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
f880: 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 .. (else (set
f890: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a ! runflag #f))).
f8a0: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
f8b0: 20 34 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 4 "RUNNING => r
f8c0: 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 unflag: " runfla
f8d0: 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 g " STATE: " (te
f8e0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
f8f0: 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 tdat) " STATUS:
f900: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
f910: 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 us testdat))..
f920: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 (if (not runfla
f930: 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 g).. (if (
f940: 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 not parent-test)
f950: 0a 09 09 20 20 20 28 69 66 20 28 72 75 6e 73 3a ... (if (runs:
f960: 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 lownoise (conc "
f970: 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 73 not starting tes
f980: 74 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d t" full-test-nam
f990: 65 29 20 36 30 29 0a 09 09 20 20 20 20 20 20 20 e) 60)...
f9a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
f9b0: 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 NOTE: Not starti
f9c0: 6e 67 20 74 65 73 74 20 22 20 66 75 6c 6c 2d 74 ng test " full-t
f9d0: 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 est-name " as it
f9e0: 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 is state \"" (t
f9f0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
fa00: 73 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 20 stdat) .....
fa10: 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 5c "\" and status \
fa20: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
fa30: 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c 22 tus testdat) "\"
fa40: 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 22 , use -rerun \""
fa50: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
fa60: 73 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 20 s testdat).....
fa70: 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 "\" or -force
fa80: 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 29 to override")))
fa90: 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 .. ;; NOTE
faa0: 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 : No longer be c
fab0: 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 hecking prerequi
fac0: 73 69 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c sites here! Will
fad0: 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 20 never get here
fae0: 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 unless prereqs a
faf0: 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 re.. ;;
fb00: 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e already met.
fb10: 0a 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 .. ;; This
fb20: 20 77 6f 75 6c 64 20 62 65 20 61 20 67 72 65 61 would be a grea
fb30: 74 20 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 68 t place to do th
fb40: 65 20 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a 09 e process-fork..
fb50: 20 20 20 20 20 20 20 3b 3b 20 0a 09 20 20 20 20 ;; ..
fb60: 20 20 20 28 6c 65 74 20 28 28 73 6b 69 70 2d 74 (let ((skip-t
fb70: 65 73 74 20 20 20 23 66 29 0a 09 09 20 20 20 20 est #f)...
fb80: 20 28 73 6b 69 70 2d 63 68 65 63 6b 20 20 28 63 (skip-check (c
fb90: 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 onfigf:get-secti
fba0: 6f 6e 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b on test-conf "sk
fbb0: 69 70 22 29 29 29 0a 09 09 20 28 63 6f 6e 64 20 ip")))... (cond
fbc0: 0a 09 09 20 20 3b 3b 20 48 61 76 65 20 74 6f 20 ... ;; Have to
fbd0: 63 68 65 63 6b 20 66 6f 72 20 73 6b 69 70 20 63 check for skip c
fbe0: 6f 6e 64 69 74 69 6f 6e 73 2e 20 54 68 69 73 20 onditions. This
fbf0: 6f 6e 65 20 73 6b 69 70 73 20 69 66 20 74 68 65 one skips if the
fc00: 72 65 20 61 72 65 20 73 61 6d 65 2d 6e 61 6d 65 re are same-name
fc10: 64 20 74 65 73 74 73 0a 09 09 20 20 3b 3b 20 63 d tests... ;; c
fc20: 75 72 72 65 6e 74 6c 79 20 72 75 6e 6e 69 6e 67 urrently running
fc30: 0a 09 09 20 20 28 28 61 6e 64 20 73 6b 69 70 2d ... ((and skip-
fc40: 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 69 67 check....(config
fc50: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f f:lookup test-co
fc60: 6e 66 20 22 73 6b 69 70 22 20 22 70 72 65 76 72 nf "skip" "prevr
fc70: 75 6e 6e 69 6e 67 22 29 29 0a 09 09 20 20 20 3b unning"))... ;
fc80: 3b 20 72 75 6e 2d 69 64 73 20 3d 20 23 66 20 6d ; run-ids = #f m
fc90: 65 61 6e 73 20 2a 61 6c 6c 2a 20 72 75 6e 73 0a eans *all* runs.
fca0: 09 09 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6e .. (let ((runn
fcb0: 69 6e 67 2d 74 65 73 74 73 20 28 72 6d 74 3a 67 ing-tests (rmt:g
fcc0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
fcd0: 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 66 75 6c s-mindata #f ful
fce0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 52 l-test-name '("R
fcf0: 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 48 UNNING" "REMOTEH
fd00: 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e 43 OSTSTART" "LAUNC
fd10: 48 45 44 22 29 20 27 28 29 20 23 66 29 29 29 0a HED") '() #f))).
fd20: 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 .. (if (not
fd30: 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 6e 67 2d 74 (null? running-t
fd40: 65 73 74 73 29 29 20 3b 3b 20 68 61 76 65 20 74 ests)) ;; have t
fd50: 6f 20 73 6b 69 70 20 0a 09 09 09 20 28 73 65 74 o skip .... (set
fd60: 21 20 73 6b 69 70 2d 74 65 73 74 20 22 53 6b 69 ! skip-test "Ski
fd70: 70 70 69 6e 67 20 64 75 65 20 74 6f 20 70 72 65 pping due to pre
fd80: 76 69 6f 75 73 20 74 65 73 74 73 20 72 75 6e 6e vious tests runn
fd90: 69 6e 67 22 29 29 29 29 0a 09 09 20 20 28 28 61 ing"))))... ((a
fda0: 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a 09 09 nd skip-check...
fdb0: 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 .(configf:lookup
fdc0: 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 test-conf "skip
fdd0: 22 20 22 66 69 6c 65 65 78 69 73 74 73 22 29 29 " "fileexists"))
fde0: 0a 09 09 20 20 20 28 69 66 20 28 66 69 6c 65 2d ... (if (file-
fdf0: 65 78 69 73 74 73 3f 20 28 63 6f 6e 66 69 67 66 exists? (configf
fe00: 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e :lookup test-con
fe10: 66 20 22 73 6b 69 70 22 20 22 66 69 6c 65 65 78 f "skip" "fileex
fe20: 69 73 74 73 22 29 29 0a 09 09 20 20 20 20 20 20 ists"))...
fe30: 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 74 (set! skip-test
fe40: 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 6e 67 (conc "Skipping
fe50: 20 64 75 65 20 74 6f 20 65 78 69 73 74 61 6e 63 due to existanc
fe60: 65 20 6f 66 20 66 69 6c 65 20 22 20 28 63 6f 6e e of file " (con
fe70: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 figf:lookup test
fe80: 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 69 -conf "skip" "fi
fe90: 6c 65 65 78 69 73 74 73 22 29 29 29 29 29 0a 0a leexists")))))..
fea0: 09 09 20 20 28 28 61 6e 64 20 73 6b 69 70 2d 63 .. ((and skip-c
feb0: 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 69 67 66 heck....(configf
fec0: 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e :lookup test-con
fed0: 66 20 22 73 6b 69 70 22 20 22 72 75 6e 64 65 6c f "skip" "rundel
fee0: 61 79 22 29 29 0a 09 09 20 20 20 3b 3b 20 72 75 ay"))... ;; ru
fef0: 6e 2d 69 64 73 20 3d 20 23 66 20 6d 65 61 6e 73 n-ids = #f means
ff00: 20 2a 61 6c 6c 2a 20 72 75 6e 73 0a 09 09 20 20 *all* runs...
ff10: 20 28 6c 65 74 2a 20 28 28 6e 75 6d 73 65 63 6f (let* ((numseco
ff20: 6e 64 73 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e nds (common
ff30: 3a 68 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 :hms-string->sec
ff40: 6f 6e 64 73 20 28 63 6f 6e 66 69 67 66 3a 6c 6f onds (configf:lo
ff50: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 okup test-conf "
ff60: 73 6b 69 70 22 20 22 72 75 6e 64 65 6c 61 79 22 skip" "rundelay"
ff70: 29 29 29 0a 09 09 09 20 20 28 72 75 6e 6e 69 6e ))).... (runnin
ff80: 67 2d 74 65 73 74 73 20 20 20 28 72 6d 74 3a 67 g-tests (rmt:g
ff90: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
ffa0: 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 66 75 6c s-mindata #f ful
ffb0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 52 l-test-name '("R
ffc0: 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 48 UNNING" "REMOTEH
ffd0: 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e 43 OSTSTART" "LAUNC
ffe0: 48 45 44 22 29 20 27 28 29 20 23 66 29 29 0a 09 HED") '() #f))..
fff0: 09 09 20 20 28 63 6f 6d 70 6c 65 74 65 64 2d 74 .. (completed-t
10000 65 73 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 ests (rmt:get-te
10010 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e sts-for-runs-min
10020 64 61 74 61 20 23 66 20 66 75 6c 6c 2d 74 65 73 data #f full-tes
10030 74 2d 6e 61 6d 65 20 27 28 22 43 4f 4d 50 4c 45 t-name '("COMPLE
10040 54 45 44 22 29 20 27 28 22 50 41 53 53 22 20 22 TED") '("PASS" "
10050 46 41 49 4c 22 20 22 41 42 4f 52 54 22 29 20 23 FAIL" "ABORT") #
10060 66 29 29 0a 09 09 09 20 20 28 6c 61 73 74 2d 72 f)).... (last-r
10070 75 6e 2d 74 69 6d 65 73 20 20 28 6d 61 70 20 64 un-times (map d
10080 62 3a 6d 69 6e 74 65 73 74 2d 67 65 74 2d 65 76 b:mintest-get-ev
10090 65 6e 74 5f 74 69 6d 65 20 63 6f 6d 70 6c 65 74 ent_time complet
100a0 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 20 ed-tests))....
100b0 28 74 69 6d 65 2d 73 69 6e 63 65 2d 6c 61 73 74 (time-since-last
100c0 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
100d0 6f 6e 64 73 29 20 28 69 66 20 28 6e 75 6c 6c 3f onds) (if (null?
100e0 20 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 73 29 last-run-times)
100f0 20 30 20 28 61 70 70 6c 79 20 6d 61 78 20 6c 61 0 (apply max la
10100 73 74 2d 72 75 6e 2d 74 69 6d 65 73 29 29 29 29 st-run-times))))
10110 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 6f 72 )... (if (or
10120 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 6e (not (null? run
10130 6e 69 6e 67 2d 74 65 73 74 73 29 29 20 3b 3b 20 ning-tests)) ;;
10140 68 61 76 65 20 74 6f 20 73 6b 69 70 20 69 66 20 have to skip if
10150 74 65 73 74 20 69 73 20 72 75 6e 6e 69 6e 67 0a test is running.
10160 09 09 09 20 20 20 20 20 28 3e 20 6e 75 6d 73 65 ... (> numse
10170 63 6f 6e 64 73 20 74 69 6d 65 2d 73 69 6e 63 65 conds time-since
10180 2d 6c 61 73 74 29 29 0a 09 09 09 20 28 73 65 74 -last)).... (set
10190 21 20 73 6b 69 70 2d 74 65 73 74 20 28 63 6f 6e ! skip-test (con
101a0 63 20 22 53 6b 69 70 70 69 6e 67 20 64 75 65 20 c "Skipping due
101b0 74 6f 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 to previous test
101c0 20 72 75 6e 20 6c 65 73 73 20 74 68 61 6e 20 22 run less than "
101d0 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
101e0 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 test-conf "skip
101f0 22 20 22 72 75 6e 64 65 6c 61 79 22 29 20 22 20 " "rundelay") "
10200 61 67 6f 22 29 29 29 29 29 29 0a 09 09 20 0a 09 ago"))))))... ..
10210 09 20 28 69 66 20 73 6b 69 70 2d 74 65 73 74 0a . (if skip-test.
10220 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 .. (begin...
10230 20 20 20 20 20 20 20 28 6d 74 3a 74 65 73 74 2d (mt:test-
10240 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
10250 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
10260 73 74 2d 69 64 20 22 43 4f 4d 50 4c 45 54 45 44 st-id "COMPLETED
10270 22 20 22 53 4b 49 50 22 20 73 6b 69 70 2d 74 65 " "SKIP" skip-te
10280 73 74 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 st)... (de
10290 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
102a0 20 22 53 4b 49 50 50 49 4e 47 20 54 65 73 74 20 "SKIPPING Test
102b0 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 " full-test-name
102c0 20 22 20 64 75 65 20 74 6f 20 22 20 73 6b 69 70 " due to " skip
102d0 2d 74 65 73 74 29 29 0a 09 09 20 20 20 20 20 28 -test))... (
102e0 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d if (not (launch-
102f0 74 65 73 74 20 74 65 73 74 2d 69 64 20 72 75 6e test test-id run
10300 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 -id run-info key
10310 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 vals runname tes
10320 74 2d 63 6f 6e 66 20 74 65 73 74 2d 6e 61 6d 65 t-conf test-name
10330 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d 64 test-path itemd
10340 61 74 20 66 6c 61 67 73 29 29 0a 09 09 09 20 28 at flags)).... (
10350 62 65 67 69 6e 0a 09 09 09 20 20 20 28 70 72 69 begin.... (pri
10360 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 nt "ERROR: Faile
10370 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 d to launch the
10380 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 73 test. Exiting as
10390 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c soon as possibl
103a0 65 22 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 e").... (set!
103b0 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
103c0 73 2a 20 31 29 20 3b 3b 20 0a 09 09 09 20 20 20 s* 1) ;; ....
103d0 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 (process-signal
103e0 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
103f0 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c -id) signal/kill
10400 29 29 29 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c ))))))))..((KILL
10410 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 72 ED) .. (debug:pr
10420 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 66 int 1 "NOTE: " f
10430 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 ull-test-name "
10440 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
10450 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 ng or was explic
10460 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 tly killed, use
10470 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 -force to launch
10480 20 69 74 2e 22 29 0a 09 20 28 68 61 73 68 2d 74 it.").. (hash-t
10490 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
104a0 65 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 egistry (db:test
104b0 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
104c0 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
104d0 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 ath) 'DONOTRUN))
104e0 20 3b 3b 20 4b 49 4c 4c 45 44 29 29 0a 09 28 28 ;; KILLED))..((
104f0 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 LAUNCHED REMOTEH
10500 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 OSTSTART RUNNING
10510 29 20 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 ) .. (debug:pri
10520 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 nt 2 "NOTE: " te
10530 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 st-name " is alr
10540 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 0a eady running")).
10550 09 3b 3b 20 28 69 66 20 28 3e 20 28 2d 20 28 63 .;; (if (> (- (c
10560 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
10570 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 + (db:test-get-e
10580 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 vent_time testda
10590 74 29 0a 09 3b 3b 20 09 09 09 20 20 20 20 20 20 t)..;; ...
105a0 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
105b0 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 n_duration testd
105c0 61 74 29 29 29 0a 09 3b 3b 20 09 28 6f 72 20 69 at)))..;; .(or i
105d0 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 6f 75 ncomplete-timeou
105e0 74 0a 09 3b 3b 20 09 20 20 20 20 36 30 30 30 29 t..;; . 6000)
105f0 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 ) ;; i.e. no upd
10600 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 ate for more tha
10610 6e 20 36 30 30 30 20 73 65 63 6f 6e 64 73 0a 09 n 6000 seconds..
10620 3b 3b 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ;; (begin..
10630 3b 3b 20 20 20 20 20 20 20 20 28 64 65 62 75 67 ;; (debug
10640 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
10650 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e G: Test " test-n
10660 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f ame " appears to
10670 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e be dead. Forcin
10680 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e g it to state IN
10690 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 COMPLETE and sta
106a0 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 tus STUCK/DEAD")
106b0 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 74 65 73 ..;; (tes
106c0 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ts:test-set-stat
106d0 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d us! run-id test-
106e0 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 id "INCOMPLETE"
106f0 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 22 20 "STUCK/DEAD" ""
10700 23 66 29 29 0a 09 3b 3b 20 20 20 20 20 20 20 20 #f))..;;
10710 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 ;; (tests:test-s
10720 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 74 2d et-status! test-
10730 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 id "INCOMPLETE"
10740 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 22 20 "STUCK/DEAD" ""
10750 23 66 29 29 0a 09 3b 3b 20 20 20 20 20 20 28 64 #f))..;; (d
10760 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f ebug:print 2 "NO
10770 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 TE: " test-name
10780 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
10790 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 ning")))..(else
107a0 20 20 20 20 20 0a 09 20 28 64 65 62 75 67 3a 70 .. (debug:p
107b0 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F
107c0 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 ailed to launch
107d0 74 65 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 test " full-test
107e0 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 -name ". Unrecog
107f0 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 74 nised state " (t
10800 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
10810 73 74 64 61 74 29 29 0a 09 20 28 63 61 73 65 20 stdat)).. (case
10820 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
10830 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
10840 74 65 73 74 64 61 74 29 29 20 0a 09 20 20 20 28 testdat)) .. (
10850 28 43 4f 4d 50 4c 45 54 45 44 20 49 4e 43 4f 4d (COMPLETED INCOM
10860 50 4c 45 54 45 29 0a 09 20 20 20 20 28 68 61 73 PLETE).. (has
10870 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
10880 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 t-registry (db:t
10890 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 est-make-full-na
108a0 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 me test-name tes
108b0 74 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 t-path) 'DONOTRU
108c0 4e 29 29 0a 09 20 20 20 28 65 6c 73 65 0a 09 20 N)).. (else..
108d0 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
108e0 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
108f0 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d y (db:test-make-
10900 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e full-name test-n
10910 61 6d 65 20 74 65 73 74 2d 70 61 74 68 29 20 27 ame test-path) '
10920 44 4f 4e 4f 54 52 55 4e 29 29 29 29 29 29 29 29 DONOTRUN))))))))
10930 0a 0a 3b 3b 3d 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 0a 3b 3b 20 45 4e ==========.;; EN
10980 44 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a 3b D OF NEW STUFF.;
10990 3b 3d 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 0a 0a 28 64 65 66 69 6e 65 =======..(define
109e0 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 (get-dir-up-n d
109f0 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 ir . params) .
10a00 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 (let ((dparts (
10a10 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 string-split dir
10a20 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 "/"))..(count
10a30 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 (if (null? para
10a40 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d ms) 1 (car param
10a50 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 s)))). (conc
10a60 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 "/" (string-inte
10a70 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 rsperse ..
10a80 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d (take dparts (-
10a90 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 (length dparts)
10aa0 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 count))..
10ab0 20 22 2f 22 29 29 29 29 0a 0a 28 64 65 66 69 6e "/"))))..(defin
10ac0 65 20 28 72 75 6e 73 3a 72 65 63 75 72 73 69 76 e (runs:recursiv
10ad0 65 2d 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 e-delete-with-er
10ae0 72 6f 72 2d 6d 73 67 20 72 65 61 6c 2d 64 69 72 ror-msg real-dir
10af0 29 0a 20 20 28 69 66 20 28 3e 20 28 73 79 73 74 ). (if (> (syst
10b00 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 em (conc "rm -rf
10b10 20 22 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 " real-dir)) 0)
10b20 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 3b . (begin..;
10b30 3b 20 46 41 49 4c 45 44 2c 20 70 6f 73 73 69 62 ; FAILED, possib
10b40 6c 79 20 64 75 65 20 74 6f 20 70 65 72 6d 69 73 ly due to permis
10b50 73 69 6f 6e 73 2c 20 64 6f 20 63 68 6d 6f 64 20 sions, do chmod
10b60 61 2b 72 77 78 20 74 68 65 6e 20 74 72 79 20 6f a+rwx then try o
10b70 6e 65 20 6d 6f 72 65 20 74 69 6d 65 0a 09 28 73 ne more time..(s
10b80 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 63 68 6d ystem (conc "chm
10b90 6f 64 20 2d 52 20 61 2b 72 77 78 20 22 20 72 65 od -R a+rwx " re
10ba0 61 6c 2d 64 69 72 29 29 0a 09 28 69 66 20 28 3e al-dir))..(if (>
10bb0 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
10bc0 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 rm -rf " real-di
10bd0 72 29 29 20 30 29 0a 09 20 20 20 20 28 64 65 62 r)) 0).. (deb
10be0 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
10bf0 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 20 70 R: There was a p
10c00 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 20 roblem removing
10c10 22 20 72 65 61 6c 2d 64 69 72 20 22 20 77 69 74 " real-dir " wit
10c20 68 20 72 6d 20 2d 66 22 29 29 29 29 29 0a 0a 28 h rm -f")))))..(
10c30 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 61 66 define (runs:saf
10c40 65 2d 64 65 6c 65 74 65 2d 74 65 73 74 2d 64 69 e-delete-test-di
10c50 72 20 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b 3b r real-dir). ;;
10c60 20 66 69 72 73 74 20 64 65 6c 65 74 65 20 61 6c first delete al
10c70 6c 20 73 75 62 2d 64 69 72 65 63 74 6f 72 69 65 l sub-directorie
10c80 73 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 s. (directory-f
10c90 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 old . (lambda
10ca0 28 66 20 78 29 0a 20 20 20 20 20 28 6c 65 74 20 (f x). (let
10cb0 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 ((fullname (conc
10cc0 20 72 65 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 real-dir "/" f)
10cd0 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 64 )). (if (d
10ce0 69 72 65 63 74 6f 72 79 3f 20 66 75 6c 6c 6e 61 irectory? fullna
10cf0 6d 65 29 28 72 75 6e 73 3a 72 65 63 75 72 73 69 me)(runs:recursi
10d00 76 65 2d 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 ve-delete-with-e
10d10 72 72 6f 72 2d 6d 73 67 20 66 75 6c 6c 6e 61 6d rror-msg fullnam
10d20 65 29 29 29 0a 20 20 20 20 20 28 2b 20 31 20 78 e))). (+ 1 x
10d30 29 29 0a 20 20 20 30 20 72 65 61 6c 2d 64 69 72 )). 0 real-dir
10d40 29 0a 20 20 3b 3b 20 74 68 65 6e 20 66 69 6c 65 ). ;; then file
10d50 73 20 6f 74 68 65 72 20 74 68 61 6e 20 2a 74 65 s other than *te
10d60 73 74 64 61 74 2e 64 62 2a 0a 20 20 28 64 69 72 stdat.db*. (dir
10d70 65 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 ectory-fold .
10d80 28 6c 61 6d 62 64 61 20 28 66 20 78 29 0a 20 20 (lambda (f x).
10d90 20 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 (let ((fullna
10da0 6d 65 20 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 me (conc real-di
10db0 72 20 22 2f 22 20 66 29 29 29 0a 20 20 20 20 20 r "/" f))).
10dc0 20 20 28 69 66 20 28 6e 6f 74 20 28 73 74 72 69 (if (not (stri
10dd0 6e 67 2d 73 65 61 72 63 68 20 28 72 65 67 65 78 ng-search (regex
10de0 70 20 22 74 65 73 74 64 61 74 2e 64 62 22 29 20 p "testdat.db")
10df0 66 29 29 0a 09 20 20 20 28 72 75 6e 73 3a 72 65 f)).. (runs:re
10e00 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d 77 cursive-delete-w
10e10 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 66 75 ith-error-msg fu
10e20 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 28 llname))). (
10e30 2b 20 31 20 78 29 29 0a 20 20 20 30 20 72 65 61 + 1 x)). 0 rea
10e40 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 68 65 6e l-dir). ;; then
10e50 20 74 68 65 20 65 6e 74 69 72 65 20 64 69 72 65 the entire dire
10e60 63 74 6f 72 79 0a 20 20 28 72 75 6e 73 3a 72 65 ctory. (runs:re
10e70 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d 77 cursive-delete-w
10e80 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 72 65 ith-error-msg re
10e90 61 6c 2d 64 69 72 29 29 0a 0a 3b 3b 20 52 65 6d al-dir))..;; Rem
10ea0 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c ove runs.;; fiel
10eb0 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 ds are passing i
10ec0 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 63 n through .;; ac
10ed0 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 6d tion:.;; 'rem
10ee0 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 27 ove-runs.;; '
10ef0 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
10f00 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 .;;.;; NB// shou
10f10 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 73 3f ld pass in keys?
10f20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e .;;.(define (run
10f30 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 61 63 74 s:operate-on act
10f40 69 6f 6e 20 74 61 72 67 65 74 20 72 75 6e 6e 61 ion target runna
10f50 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 74 20 mepatt testpatt
10f60 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 29 #!key (state #f)
10f70 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 2d (status #f)(new-
10f80 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 29 state-status #f)
10f90 28 6d 6f 64 65 20 27 72 65 6d 6f 76 65 2d 61 6c (mode 'remove-al
10fa0 6c 29 28 6f 70 74 69 6f 6e 73 20 27 28 29 29 29 l)(options '()))
10fb0 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 . (common:clear
10fc0 2d 63 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 -caches) ;; clea
10fd0 72 20 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 r all caches. (
10fe0 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 let* ((db
10ff0 20 20 20 20 23 66 29 0a 09 20 28 74 64 62 64 61 #f).. (tdbda
11000 74 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f t (tasks:o
11010 70 65 6e 2d 64 62 29 29 0a 09 20 28 6b 65 79 73 pen-db)).. (keys
11020 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
11030 74 2d 6b 65 79 73 29 29 0a 09 20 28 72 75 6e 64 t-keys)).. (rund
11040 61 74 20 20 20 20 20 20 20 28 6d 74 3a 67 65 74 at (mt:get
11050 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 -runs-by-patt ke
11060 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
11070 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 arget)).. (heade
11080 72 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d r (vector-
11090 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
110a0 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 20 28 (runs (
110b0 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
110c0 74 20 31 29 29 0a 09 20 28 73 74 61 74 65 73 20 t 1)).. (states
110d0 20 20 20 20 20 20 28 69 66 20 73 74 61 74 65 20 (if state
110e0 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 (string-split s
110f0 74 61 74 65 20 20 22 2c 22 29 20 27 28 29 29 29 tate ",") '()))
11100 0a 09 20 28 73 74 61 74 75 73 65 73 20 20 20 20 .. (statuses
11110 20 28 69 66 20 73 74 61 74 75 73 20 28 73 74 72 (if status (str
11120 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 75 73 ing-split status
11130 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 ",") '())).. (s
11140 74 61 74 65 2d 73 74 61 74 75 73 20 28 69 66 20 tate-status (if
11150 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 61 (string? new-sta
11160 74 65 2d 73 74 61 74 75 73 29 20 28 73 74 72 69 te-status) (stri
11170 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 61 ng-split new-sta
11180 74 65 2d 73 74 61 74 75 73 20 22 2c 22 29 20 27 te-status ",") '
11190 28 23 66 20 23 66 29 29 29 29 0a 20 20 20 20 28 (#f #f)))). (
111a0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
111b0 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 4 "runs:operate
111c0 2d 6f 6e 20 3d 3e 20 48 65 61 64 65 72 3a 20 22 -on => Header: "
111d0 20 68 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e header " action
111e0 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 : " action " new
111f0 2d 73 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 -state-status: "
11200 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 new-state-statu
11210 73 29 0a 20 20 20 20 28 69 66 20 28 3e 20 32 20 s). (if (> 2
11220 28 6c 65 6e 67 74 68 20 73 74 61 74 65 2d 73 74 (length state-st
11230 61 74 75 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 atus))..(begin..
11240 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
11250 20 22 45 52 52 4f 52 3a 20 74 68 65 20 70 61 72 "ERROR: the par
11260 61 6d 65 74 65 72 20 74 6f 20 2d 73 65 74 2d 73 ameter to -set-s
11270 74 61 74 65 2d 73 74 61 74 75 73 20 69 73 20 61 tate-status is a
11280 20 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 65 64 comma delimited
11290 20 73 74 72 69 6e 67 2e 20 45 2e 67 2e 20 43 4f string. E.g. CO
112a0 4d 50 4c 45 54 45 44 2c 46 41 49 4c 22 29 0a 09 MPLETED,FAIL")..
112b0 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 (exit))). (
112c0 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
112d0 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 ambda (run).
112e0 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 79 (let ((runkey
112f0 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
11300 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 erse (map (lambd
11310 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 62 3a a (k).......(db:
11320 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
11330 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 6b der run header k
11340 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 )) keys) "/"))..
11350 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 (dirs-to-re
11360 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d move (make-hash-
11370 74 61 62 6c 65 29 29 0a 09 20 20 20 20 20 28 70 table)).. (p
11380 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 28 6c roc-get-tests (l
11390 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 ambda (run-id)..
113a0 09 09 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d .. (mt:get-
113b0 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 tests-for-run ru
113c0 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 20 20 74 n-id....... t
113d0 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
113e0 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 20 tatuses.......
113f0 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 not-in: #f...
11400 09 09 09 09 20 20 20 20 73 6f 72 74 2d 62 79 3a .... sort-by:
11410 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 (case action...
11420 09 09 09 09 09 20 20 20 20 20 20 20 28 28 72 65 ..... ((re
11430 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 move-runs) 'rund
11440 69 72 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 ir)........
11450 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
11460 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 29 'event_time))))
11470 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e )).. (let* ((run
11480 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d 76 -id (db:get-v
11490 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
114a0 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 un header "id"))
114b0 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 64 ...(run-state (d
114c0 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
114d0 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
114e0 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 72 75 "state"))...(ru
114f0 6e 2d 6e 61 6d 65 20 20 28 64 62 3a 67 65 74 2d n-name (db:get-
11500 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
11510 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
11520 61 6d 65 22 29 29 0a 09 09 28 74 65 73 74 73 20 ame"))...(tests
11530 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
11540 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 ual? run-state "
11550 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 20 locked"))....
11560 20 20 20 20 28 70 72 6f 63 2d 67 65 74 2d 74 65 (proc-get-te
11570 73 74 73 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 sts run-id)....
11580 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c '()))...(l
11590 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f asttpath "/does/
115a0 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 not/exist/I/hope
115b0 22 29 0a 09 09 28 77 6f 72 6b 65 72 2d 74 68 72 ")...(worker-thr
115c0 65 61 64 20 23 66 29 29 0a 09 20 20 20 28 64 65 ead #f)).. (de
115d0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
115e0 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f "runs:operate-o
115f0 6e 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 68 n run=" run ", h
11600 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 0a eader=" header).
11610 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 . (if (not (nu
11620 6c 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 20 20 ll? tests))..
11630 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 63 (begin... (c
11640 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 ase action...
11650 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 ((remove-runs)..
11660 09 20 20 20 20 28 69 66 20 28 74 61 73 6b 73 3a . (if (tasks:
11670 6e 65 65 64 2d 73 65 72 76 65 72 20 72 75 6e 2d need-server run-
11680 69 64 29 28 74 61 73 6b 73 3a 73 74 61 72 74 2d id)(tasks:start-
11690 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 and-wait-for-ser
116a0 76 65 72 20 74 64 62 64 61 74 20 72 75 6e 2d 69 ver tdbdat run-i
116b0 64 20 31 30 29 29 0a 09 09 20 20 20 20 3b 3b 20 d 10))... ;;
116c0 73 65 65 6b 20 61 6e 64 20 6b 69 6c 6c 20 69 6e seek and kill in
116d0 20 66 6c 69 67 68 74 20 2d 72 75 6e 74 65 73 74 flight -runtest
116e0 73 20 77 69 74 68 20 25 20 61 73 20 74 65 73 74 s with % as test
116f0 70 61 74 74 20 68 65 72 65 0a 09 09 20 20 20 20 patt here...
11700 28 69 66 20 28 65 71 75 61 6c 3f 20 74 65 73 74 (if (equal? test
11710 70 61 74 74 20 22 25 22 29 0a 09 09 09 28 74 61 patt "%")....(ta
11720 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 72 20 sks:kill-runner
11730 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 29 target run-name)
11740 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
11750 20 30 20 22 6e 6f 74 20 61 74 74 65 6d 70 74 69 0 "not attempti
11760 6e 67 20 74 6f 20 6b 69 6c 6c 20 61 6e 79 20 72 ng to kill any r
11770 75 6e 20 6c 61 75 6e 63 68 65 72 20 70 72 6f 63 un launcher proc
11780 65 73 73 65 73 20 61 73 20 74 65 73 74 70 61 74 esses as testpat
11790 74 20 69 73 20 22 20 74 65 73 74 70 61 74 74 29 t is " testpatt)
117a0 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
117b0 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 rint 1 "Removing
117c0 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 tests for run:
117d0 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 " runkey " " (db
117e0 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
117f0 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
11800 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 "runname")))...
11810 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 ((set-state-st
11820 61 74 75 73 29 0a 09 09 20 20 20 20 28 69 66 20 atus)... (if
11830 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 76 (tasks:need-serv
11840 65 72 20 72 75 6e 2d 69 64 29 28 74 61 73 6b 73 er run-id)(tasks
11850 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 2d :start-and-wait-
11860 66 6f 72 2d 73 65 72 76 65 72 20 74 64 62 64 61 for-server tdbda
11870 74 20 72 75 6e 2d 69 64 20 31 30 29 29 0a 09 09 t run-id 10))...
11880 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
11890 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 1 "Modifying st
118a0 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f ate and staus fo
118b0 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a r tests for run:
118c0 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
118d0 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
118e0 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
118f0 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
11900 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 0a ((print-run).
11910 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
11920 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 20 69 nt 1 "Printing i
11930 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 75 nfo for run " ru
11940 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 nkey ", run=" ru
11950 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 65 73 n ", tests=" tes
11960 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 ts ", header=" h
11970 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 63 74 eader)... act
11980 69 6f 6e 29 0a 09 09 20 20 20 28 28 72 75 6e 2d ion)... ((run-
11990 77 61 69 74 29 0a 09 09 20 20 20 20 28 64 65 62 wait)... (deb
119a0 75 67 3a 70 72 69 6e 74 20 31 20 22 57 61 69 74 ug:print 1 "Wait
119b0 69 6e 67 20 66 6f 72 20 72 75 6e 20 22 20 72 75 ing for run " ru
119c0 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 nkey ", run=" ru
119d0 6e 6e 61 6d 65 70 61 74 74 20 22 20 74 6f 20 63 nnamepatt " to c
119e0 6f 6d 70 6c 65 74 65 22 29 29 0a 09 09 20 20 20 omplete"))...
119f0 28 28 61 72 63 68 69 76 65 29 0a 09 09 20 20 20 ((archive)...
11a00 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
11a10 22 41 72 63 68 69 76 69 6e 67 2f 72 65 73 74 6f "Archiving/resto
11a20 72 69 6e 67 20 28 22 20 28 61 72 67 73 3a 67 65 ring (" (args:ge
11a30 74 2d 61 72 67 20 22 2d 61 72 63 68 69 76 65 22 t-arg "-archive"
11a40 29 20 22 29 20 64 61 74 61 20 66 6f 72 20 72 75 ) ") data for ru
11a50 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
11a60 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
11a70 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
11a80 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a 09 er "runname"))..
11a90 09 20 20 20 20 28 73 65 74 21 20 77 6f 72 6b 65 . (set! worke
11aa0 72 2d 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 r-thread (make-t
11ab0 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 hread (lambda ()
11ac0 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 63 ....... (c
11ad0 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
11ae0 62 6f 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 72 bol (args:get-ar
11af0 67 20 22 2d 61 72 63 68 69 76 65 22 29 29 0a 09 g "-archive"))..
11b00 09 09 09 09 09 09 20 28 28 73 61 76 65 20 73 61 ...... ((save sa
11b10 76 65 2d 72 65 6d 6f 76 65 20 6b 65 65 70 2d 68 ve-remove keep-h
11b20 74 6d 6c 29 28 61 72 63 68 69 76 65 3a 72 75 6e tml)(archive:run
11b30 2d 62 75 70 20 28 61 72 67 73 3a 67 65 74 2d 61 -bup (args:get-a
11b40 72 67 20 22 2d 61 72 63 68 69 76 65 22 29 20 72 rg "-archive") r
11b50 75 6e 2d 69 64 20 72 75 6e 2d 6e 61 6d 65 20 74 un-id run-name t
11b60 65 73 74 73 29 29 0a 09 09 09 09 09 09 09 20 28 ests))........ (
11b70 28 72 65 73 74 6f 72 65 29 28 61 72 63 68 69 76 (restore)(archiv
11b80 65 3a 62 75 70 2d 72 65 73 74 6f 72 65 20 28 61 e:bup-restore (a
11b90 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 rgs:get-arg "-ar
11ba0 63 68 69 76 65 22 29 20 72 75 6e 2d 69 64 20 72 chive") run-id r
11bb0 75 6e 2d 6e 61 6d 65 20 74 65 73 74 73 29 29 0a un-name tests)).
11bc0 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 0a 09 ....... (else ..
11bd0 09 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 ...... (debug:p
11be0 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 75 rint 0 "ERROR: u
11bf0 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 75 62 20 nrecognised sub
11c00 63 6f 6d 6d 61 6e 64 20 74 6f 20 2d 61 72 63 68 command to -arch
11c10 69 76 65 2e 20 52 75 6e 20 5c 22 6d 65 67 61 74 ive. Run \"megat
11c20 65 73 74 5c 22 20 74 6f 20 73 65 65 20 68 65 6c est\" to see hel
11c30 70 22 29 0a 09 09 09 09 09 09 09 20 20 28 65 78 p")........ (ex
11c40 69 74 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 it)))).......
11c50 20 20 22 61 72 63 68 69 76 65 2d 62 75 70 2d 74 "archive-bup-t
11c60 68 72 65 61 64 22 29 29 0a 09 09 20 20 20 20 28 hread"))... (
11c70 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 77 6f thread-start! wo
11c80 72 6b 65 72 2d 74 68 72 65 61 64 29 29 0a 09 09 rker-thread))...
11c90 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 (else... (
11ca0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
11cb0 20 30 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 72 0 "action not r
11cc0 65 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 ecognised " acti
11cd0 6f 6e 29 29 29 0a 09 09 20 0a 09 09 20 3b 3b 20 on)))... ... ;;
11ce0 61 63 74 69 6f 6e 73 20 74 68 61 74 20 6f 70 65 actions that ope
11cf0 72 61 74 65 20 6f 6e 20 6f 6e 65 20 74 65 73 74 rate on one test
11d00 20 61 74 20 61 20 74 69 6d 65 20 63 61 6e 20 62 at a time can b
11d10 65 20 68 61 6e 64 6c 65 64 20 62 65 6c 6f 77 0a e handled below.
11d20 09 09 20 3b 3b 0a 09 09 20 28 6c 65 74 20 28 28 .. ;;... (let ((
11d30 73 6f 72 74 65 64 2d 74 65 73 74 73 20 20 20 20 sorted-tests
11d40 20 28 66 69 6c 74 65 72 20 0a 09 09 09 09 09 20 (filter ......
11d50 20 76 65 63 74 6f 72 3f 0a 09 09 09 09 09 20 20 vector?......
11d60 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d (sort tests (lam
11d70 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 bda (a b)(let ((
11d80 64 69 72 61 20 3b 3b 20 28 72 6d 74 3a 73 64 62 dira ;; (rmt:sdb
11d90 2d 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 09 -qry 'getstr ...
11da0 09 09 09 09 09 09 09 20 20 28 64 62 3a 74 65 73 ....... (db:tes
11db0 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 t-get-rundir a))
11dc0 20 3b 3b 20 29 20 20 3b 3b 20 28 66 69 6c 65 64 ;; ) ;; (filed
11dd0 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 62 2a b:get-path *fdb*
11de0 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
11df0 6e 64 69 72 20 61 29 29 29 0a 09 09 09 09 09 09 ndir a))).......
11e00 09 09 09 20 28 64 69 72 62 20 3b 3b 20 28 72 6d ... (dirb ;; (rm
11e10 74 3a 73 64 62 2d 71 72 79 20 27 67 65 74 73 74 t:sdb-qry 'getst
11e20 72 20 0a 09 09 09 09 09 09 09 09 09 20 20 28 64 r .......... (d
11e30 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
11e40 72 20 62 29 29 29 20 3b 3b 20 29 20 3b 3b 20 28 r b))) ;; ) ;; (
11e50 28 66 69 6c 65 64 62 3a 67 65 74 2d 70 61 74 68 (filedb:get-path
11e60 20 2a 66 64 62 2a 20 28 64 62 3a 74 65 73 74 2d *fdb* (db:test-
11e70 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 29 29 get-rundir b))))
11e80 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 28 69 ......... (i
11e90 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 f (and (string?
11ea0 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 69 dira)(string? di
11eb0 72 62 29 29 0a 09 09 09 09 09 09 09 09 09 20 28 rb)).......... (
11ec0 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 > (string-length
11ed0 20 64 69 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 dira)(string-le
11ee0 6e 67 74 68 20 64 69 72 62 29 29 0a 09 09 09 09 ngth dirb)).....
11ef0 09 09 09 09 09 20 23 66 29 29 29 29 29 29 0a 09 ..... #f))))))..
11f00 09 20 20 20 20 20 20 20 28 74 6f 70 6c 65 76 65 . (topleve
11f10 6c 2d 72 65 74 72 69 65 73 20 28 6d 61 6b 65 2d l-retries (make-
11f20 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
11f30 74 72 79 20 74 68 72 65 65 20 74 69 6d 65 73 20 try three times
11f40 74 6f 20 6c 6f 6f 70 20 74 68 72 6f 75 67 68 20 to loop through
11f50 61 6e 64 20 72 65 6d 6f 76 65 20 74 6f 70 20 6c and remove top l
11f60 65 76 65 6c 20 74 65 73 74 73 0a 09 09 20 20 20 evel tests...
11f70 20 20 20 20 28 74 65 73 74 2d 72 65 74 72 79 2d (test-retry-
11f80 74 69 6d 65 20 20 28 6d 61 6b 65 2d 68 61 73 68 time (make-hash
11f90 2d 74 61 62 6c 65 29 29 0a 09 09 20 20 20 20 20 -table))...
11fa0 20 20 28 61 6c 6c 6f 77 2d 72 75 6e 2d 74 69 6d (allow-run-tim
11fb0 65 20 20 20 31 30 29 29 20 3b 3b 20 73 65 63 6f e 10)) ;; seco
11fc0 6e 64 73 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 nds to allow for
11fd0 20 6b 69 6c 6c 69 6e 67 20 74 65 73 74 73 20 62 killing tests b
11fe0 65 66 6f 72 65 20 6a 75 73 74 20 62 72 75 74 61 efore just bruta
11ff0 6c 6c 79 20 6b 69 6c 6c 69 6e 67 20 27 65 6d 0a lly killing 'em.
12000 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 .. (let loop (
12010 28 74 65 73 74 20 28 63 61 72 20 73 6f 72 74 65 (test (car sorte
12020 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 20 20 d-tests))....
12030 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 73 6f (tal (cdr so
12040 72 74 65 64 2d 74 65 73 74 73 29 29 29 0a 09 09 rted-tests)))...
12050 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
12060 74 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a 74 t-id (db:t
12070 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
12080 29 0a 09 09 09 20 20 20 20 28 6e 65 77 2d 74 65 ).... (new-te
12090 73 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 74 st-dat (rmt:get
120a0 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
120b0 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
120c0 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 ))... (if
120d0 28 6e 6f 74 20 6e 65 77 2d 74 65 73 74 2d 64 61 (not new-test-da
120e0 74 29 0a 09 09 09 20 20 20 28 62 65 67 69 6e 0a t).... (begin.
120f0 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
12100 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 57 rint 0 "ERROR: W
12110 65 20 68 61 76 65 20 61 20 74 65 73 74 2d 69 64 e have a test-id
12120 20 6f 66 20 22 20 74 65 73 74 2d 69 64 20 22 20 of " test-id "
12130 62 75 74 20 6e 6f 20 72 65 63 6f 72 64 20 77 61 but no record wa
12140 73 20 66 6f 75 6e 64 2e 20 4e 4f 54 45 3a 20 4e s found. NOTE: N
12150 6f 20 6c 6f 63 6b 69 6e 67 20 6f 66 20 72 65 63 o locking of rec
12160 6f 72 64 73 20 69 73 20 64 6f 6e 65 20 62 65 74 ords is done bet
12170 77 65 65 6e 20 70 72 6f 63 65 73 73 65 73 2c 20 ween processes,
12180 64 6f 20 6e 6f 74 20 73 69 6d 75 6c 74 61 6e 65 do not simultane
12190 6f 75 73 6c 79 20 72 65 6d 6f 76 65 20 74 68 65 ously remove the
121a0 20 73 61 6d 65 20 72 75 6e 20 66 72 6f 6d 20 74 same run from t
121b0 77 6f 20 70 72 6f 63 65 73 73 65 73 21 22 29 0a wo processes!").
121c0 09 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ... (if (not
121d0 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
121e0 09 09 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 .. (loop (car ta
121f0 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a 09 l)(cdr tal))))..
12200 09 09 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 .. (let* ((ite
12210 6d 2d 70 61 74 68 20 20 20 20 20 28 64 62 3a 74 m-path (db:t
12220 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
12230 68 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 h new-test-dat))
12240 0a 09 09 09 09 20 20 28 74 65 73 74 2d 6e 61 6d ..... (test-nam
12250 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 e (db:test-g
12260 65 74 2d 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d et-testname new-
12270 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 test-dat)).....
12280 20 28 72 75 6e 2d 64 69 72 20 20 20 20 20 20 20 (run-dir
12290 3b 3b 28 66 69 6c 65 64 62 3a 67 65 74 2d 70 61 ;;(filedb:get-pa
122a0 74 68 20 2a 66 64 62 2a 0a 09 09 09 09 20 20 20 th *fdb*.....
122b0 3b 3b 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 ;; (rmt:sdb-qry
122c0 27 67 65 74 69 64 20 0a 09 09 09 09 20 20 20 28 'getid ..... (
122d0 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
122e0 69 72 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 ir new-test-dat)
122f0 29 20 3b 3b 20 29 20 20 20 20 3b 3b 20 72 75 6e ) ;; ) ;; run
12300 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 dir is from the
12310 20 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 09 20 link tree.....
12320 20 28 74 65 73 74 2d 73 74 61 74 65 20 20 20 20 (test-state
12330 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
12340 74 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 te new-test-dat)
12350 29 0a 09 09 09 09 20 20 28 74 65 73 74 2d 66 75 )..... (test-fu
12360 6c 6c 6e 20 20 20 20 28 64 62 3a 74 65 73 74 2d lln (db:test-
12370 67 65 74 2d 66 75 6c 6c 6e 61 6d 65 20 6e 65 77 get-fullname new
12380 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 -test-dat)).....
12390 20 20 28 75 6e 61 6d 65 20 20 20 20 20 20 20 20 (uname
123a0 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 75 6e (db:test-get-un
123b0 61 6d 65 20 20 20 20 6e 65 77 2d 74 65 73 74 2d ame new-test-
123c0 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 6f 70 dat))..... (top
123d0 6c 65 76 65 6c 2d 77 69 74 68 2d 63 68 69 6c 64 level-with-child
123e0 72 65 6e 20 28 61 6e 64 20 28 64 62 3a 74 65 73 ren (and (db:tes
123f0 74 2d 67 65 74 2d 69 73 2d 74 6f 70 6c 65 76 65 t-get-is-topleve
12400 6c 20 74 65 73 74 29 0a 09 09 09 09 09 09 09 20 l test)........
12410 20 20 20 20 20 20 28 3e 20 28 72 6d 74 3a 74 65 (> (rmt:te
12420 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d st-toplevel-num-
12430 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 items run-id tes
12440 74 2d 6e 61 6d 65 29 20 30 29 29 29 29 0a 09 09 t-name) 0))))...
12450 09 20 20 20 20 20 28 63 61 73 65 20 61 63 74 69 . (case acti
12460 6f 6e 0a 09 09 09 20 20 20 20 20 20 20 28 28 72 on.... ((r
12470 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 09 09 emove-runs).....
12480 3b 3b 20 69 66 20 74 68 65 20 74 65 73 74 20 69 ;; if the test i
12490 73 20 61 20 74 6f 70 6c 65 76 65 6c 2d 77 69 74 s a toplevel-wit
124a0 68 2d 63 68 69 6c 64 72 65 6e 20 69 73 73 75 65 h-children issue
124b0 20 61 6e 20 65 72 72 6f 72 20 61 6e 64 20 64 6f an error and do
124c0 20 6e 6f 74 20 72 65 6d 6f 76 65 0a 09 09 09 09 not remove.....
124d0 28 69 66 20 74 6f 70 6c 65 76 65 6c 2d 77 69 74 (if toplevel-wit
124e0 68 2d 63 68 69 6c 64 72 65 6e 0a 09 09 09 09 20 h-children.....
124f0 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 (begin.....
12500 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
12510 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 73 6b 69 0 "WARNING: ski
12520 70 70 69 6e 67 20 72 65 6d 6f 76 61 6c 20 6f 66 pping removal of
12530 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e 20 22 20 " test-fulln "
12540 77 69 74 68 20 72 75 6e 2d 69 64 20 22 20 72 75 with run-id " ru
12550 6e 2d 69 64 20 22 20 61 73 20 69 74 20 68 61 73 n-id " as it has
12560 20 73 75 62 20 74 65 73 74 73 22 29 0a 09 09 09 sub tests")....
12570 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
12580 6c 65 2d 73 65 74 21 20 74 6f 70 6c 65 76 65 6c le-set! toplevel
12590 2d 72 65 74 72 69 65 73 20 74 65 73 74 2d 66 75 -retries test-fu
125a0 6c 6c 6e 20 28 2b 20 28 68 61 73 68 2d 74 61 62 lln (+ (hash-tab
125b0 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
125c0 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 73 20 oplevel-retries
125d0 74 65 73 74 2d 66 75 6c 6c 6e 20 30 29 20 31 29 test-fulln 0) 1)
125e0 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 20 )..... (if
125f0 28 3e 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (> (hash-table-r
12600 65 66 20 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 ef toplevel-retr
12610 69 65 73 20 74 65 73 74 2d 66 75 6c 6c 6e 29 20 ies test-fulln)
12620 33 29 0a 09 09 09 09 09 20 20 28 69 66 20 28 6e 3)...... (if (n
12630 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
12640 09 09 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ..... (loop
12650 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
12660 61 6c 29 29 29 20 3b 3b 20 6e 6f 20 65 6c 73 65 al))) ;; no else
12670 20 63 6c 61 75 73 65 20 2d 20 64 72 6f 70 20 69 clause - drop i
12680 74 20 69 66 20 6e 6f 20 6d 6f 72 65 20 69 6e 20 t if no more in
12690 71 75 65 75 65 20 61 6e 64 20 3e 20 33 20 74 72 queue and > 3 tr
126a0 69 65 73 0a 09 09 09 09 09 20 20 28 6c 65 74 20 ies...... (let
126b0 28 28 6e 65 77 74 61 6c 20 28 61 70 70 65 6e 64 ((newtal (append
126c0 20 74 61 6c 20 28 6c 69 73 74 20 74 65 73 74 29 tal (list test)
126d0 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 6c 6f )))...... (lo
126e0 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 op (car newtal)(
126f0 63 64 72 20 6e 65 77 74 61 6c 29 29 29 29 29 20 cdr newtal)))))
12700 3b 3b 20 6c 6f 6f 70 20 77 69 74 68 20 74 65 73 ;; loop with tes
12710 74 20 73 74 69 6c 6c 20 69 6e 20 71 75 65 75 65 t still in queue
12720 0a 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a ..... (begin.
12730 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
12740 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 :print-info 0 "t
12750 65 73 74 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 est: " test-name
12760 20 22 20 69 74 65 73 74 2d 73 74 61 74 65 3a 20 " itest-state:
12770 22 20 74 65 73 74 2d 73 74 61 74 65 29 0a 09 09 " test-state)...
12780 09 09 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d .. (if (mem
12790 62 65 72 20 74 65 73 74 2d 73 74 61 74 65 20 28 ber test-state (
127a0 6c 69 73 74 20 22 52 55 4e 4e 49 4e 47 22 20 22 list "RUNNING" "
127b0 4c 41 55 4e 43 48 45 44 22 20 22 52 45 4d 4f 54 LAUNCHED" "REMOT
127c0 45 48 4f 53 54 53 54 41 52 54 22 20 22 4b 49 4c EHOSTSTART" "KIL
127d0 4c 52 45 51 22 29 29 0a 09 09 09 09 09 20 20 28 LREQ"))...... (
127e0 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 28 begin...... (
127f0 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
12800 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
12810 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 test-retry-time
12820 74 65 73 74 2d 66 75 6c 6c 6e 20 23 66 29 29 0a test-fulln #f)).
12830 09 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ......(begin....
12840 09 09 09 20 20 3b 3b 20 77 61 6e 74 20 74 6f 20 ... ;; want to
12850 73 65 74 20 74 6f 20 52 45 4d 4f 56 49 4e 47 20 set to REMOVING
12860 42 55 54 20 43 41 4e 4e 4f 54 20 64 6f 20 69 74 BUT CANNOT do it
12870 20 68 65 72 65 3f 0a 09 09 09 09 09 09 20 20 28 here?....... (
12880 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
12890 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 test-retry-time
128a0 74 65 73 74 2d 66 75 6c 6c 6e 20 28 63 75 72 72 test-fulln (curr
128b0 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
128c0 09 09 09 09 09 20 20 20 20 28 69 66 20 28 3e 20 ..... (if (>
128d0 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
128e0 6e 64 73 29 28 68 61 73 68 2d 74 61 62 6c 65 2d nds)(hash-table-
128f0 72 65 66 20 74 65 73 74 2d 72 65 74 72 79 2d 74 ref test-retry-t
12900 69 6d 65 20 74 65 73 74 2d 66 75 6c 6c 6e 29 29 ime test-fulln))
12910 20 61 6c 6c 6f 77 2d 72 75 6e 2d 74 69 6d 65 29 allow-run-time)
12920 0a 09 09 09 09 09 09 3b 3b 20 54 68 69 73 20 74 .......;; This t
12930 65 73 74 20 69 73 20 6e 6f 74 20 69 6e 20 61 20 est is not in a
12940 63 6f 72 72 65 63 74 20 73 74 61 74 65 20 66 6f correct state fo
12950 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 2e 20 4c r cleaning up. L
12960 65 74 27 73 20 74 72 79 20 73 6f 6d 65 20 67 72 et's try some gr
12970 61 63 65 66 75 6c 20 73 68 75 74 64 6f 77 6e 20 aceful shutdown
12980 73 74 65 70 73 20 66 69 72 73 74 0a 09 09 09 09 steps first.....
12990 09 09 3b 3b 20 53 65 74 20 74 68 65 20 74 65 73 ..;; Set the tes
129a0 74 20 74 6f 20 22 4b 49 4c 4c 52 45 51 22 20 61 t to "KILLREQ" a
129b0 6e 64 20 77 61 69 74 20 66 69 76 65 20 73 65 63 nd wait five sec
129c0 6f 6e 64 73 20 74 68 65 6e 20 74 72 79 20 61 67 onds then try ag
129d0 61 69 6e 2e 20 52 65 70 65 61 74 20 75 70 20 74 ain. Repeat up t
129e0 6f 20 66 69 76 65 20 74 69 6d 65 73 20 74 68 65 o five times the
129f0 6e 20 67 69 76 65 0a 09 09 09 09 09 09 3b 3b 20 n give.......;;
12a00 75 70 20 61 6e 64 20 62 6c 6f 77 20 69 74 20 61 up and blow it a
12a10 77 61 79 2e 0a 09 09 09 09 09 09 28 62 65 67 69 way........(begi
12a20 6e 0a 09 09 09 09 09 09 20 20 28 64 65 62 75 67 n....... (debug
12a30 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
12a40 47 3a 20 63 6f 75 6c 64 20 6e 6f 74 20 67 72 61 G: could not gra
12a50 63 65 66 75 6c 6c 79 20 72 65 6d 6f 76 65 20 74 cefully remove t
12a60 65 73 74 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e est " test-fulln
12a70 20 22 2c 20 74 72 69 65 64 20 74 6f 20 6b 69 6c ", tried to kil
12a80 6c 20 69 74 20 74 6f 20 6e 6f 20 61 76 61 69 6c l it to no avail
12a90 2e 20 46 6f 72 63 69 6e 67 20 73 74 61 74 65 20 . Forcing state
12aa0 74 6f 20 46 41 49 4c 45 44 4b 49 4c 4c 20 61 6e to FAILEDKILL an
12ab0 64 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 09 d continuing")..
12ac0 09 09 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 .... (mt:test
12ad0 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
12ae0 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 s-by-id run-id (
12af0 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
12b00 65 73 74 29 20 22 46 41 49 4c 45 44 4b 49 4c 4c est) "FAILEDKILL
12b10 22 20 22 6e 2f 61 22 20 23 66 29 0a 09 09 09 09 " "n/a" #f).....
12b20 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
12b30 70 21 20 31 29 29 0a 09 09 09 09 09 09 28 62 65 p! 1)).......(be
12b40 67 69 6e 0a 09 09 09 09 09 20 20 20 20 28 6d 74 gin...... (mt
12b50 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
12b60 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
12b70 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
12b80 2d 69 64 20 74 65 73 74 29 20 22 4b 49 4c 4c 52 -id test) "KILLR
12b90 45 51 22 20 22 6e 2f 61 22 20 23 66 29 0a 09 09 EQ" "n/a" #f)...
12ba0 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
12bb0 65 65 70 21 20 31 29 29 29 0a 09 09 09 09 09 20 eep! 1)))......
12bc0 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 ;; NOTE: This
12bd0 20 69 73 20 73 75 62 6f 70 74 69 6d 61 6c 20 61 is suboptimal a
12be0 73 20 74 68 65 20 74 65 73 74 64 61 74 61 20 77 s the testdata w
12bf0 69 6c 6c 20 62 65 20 75 73 65 64 20 6c 61 74 65 ill be used late
12c00 72 20 61 6e 64 20 74 68 65 20 73 74 61 74 65 2f r and the state/
12c10 73 74 61 74 75 73 20 6d 61 79 20 68 61 76 65 20 status may have
12c20 63 68 61 6e 67 65 64 20 2e 2e 2e 0a 09 09 09 09 changed ........
12c30 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
12c40 74 61 6c 29 0a 09 09 09 09 09 09 28 6c 6f 6f 70 tal).......(loop
12c50 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 20 74 61 new-test-dat ta
12c60 6c 29 0a 09 09 09 09 09 09 28 6c 6f 6f 70 20 28 l).......(loop (
12c70 63 61 72 20 74 61 6c 29 28 61 70 70 65 6e 64 20 car tal)(append
12c80 74 61 6c 20 28 6c 69 73 74 20 6e 65 77 2d 74 65 tal (list new-te
12c90 73 74 2d 64 61 74 29 29 29 29 29 0a 09 09 09 09 st-dat))))).....
12ca0 09 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 . (begin......
12cb0 20 20 20 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d (runs:remove-
12cc0 74 65 73 74 2d 64 69 72 65 63 74 6f 72 79 20 6e test-directory n
12cd0 65 77 2d 74 65 73 74 2d 64 61 74 20 6d 6f 64 65 ew-test-dat mode
12ce0 29 20 3b 3b 20 27 72 65 6d 6f 76 65 2d 61 6c 6c ) ;; 'remove-all
12cf0 29 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 28 )...... (if (
12d00 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
12d10 0a 09 09 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 .......(loop (ca
12d20 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
12d30 29 29 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 ))))))....
12d40 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 ((set-state-sta
12d50 74 75 73 29 0a 09 09 09 09 28 64 65 62 75 67 3a tus).....(debug:
12d60 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 65 print-info 2 "ne
12d70 77 20 73 74 61 74 65 20 22 20 28 63 61 72 20 73 w state " (car s
12d80 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 tate-status) ",
12d90 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 63 61 new status " (ca
12da0 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 dr state-status)
12db0 29 0a 09 09 09 09 28 6d 74 3a 74 65 73 74 2d 73 ).....(mt:test-s
12dc0 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
12dd0 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 64 62 by-id run-id (db
12de0 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
12df0 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 t) (car state-st
12e00 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 65 atus)(cadr state
12e10 2d 73 74 61 74 75 73 29 20 23 66 29 0a 09 09 09 -status) #f)....
12e20 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f .(if (not (null?
12e30 20 74 61 6c 29 29 0a 09 09 09 09 20 20 20 20 28 tal))..... (
12e40 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
12e50 64 72 20 74 61 6c 29 29 29 29 0a 09 09 09 20 20 dr tal))))....
12e60 20 20 20 20 20 28 28 72 75 6e 2d 77 61 69 74 29 ((run-wait)
12e70 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
12e80 74 2d 69 6e 66 6f 20 32 20 22 73 74 69 6c 6c 20 t-info 2 "still
12e90 77 61 69 74 69 6e 67 2c 20 22 20 28 6c 65 6e 67 waiting, " (leng
12ea0 74 68 20 74 65 73 74 73 29 20 22 20 74 65 73 74 th tests) " test
12eb0 73 20 73 74 69 6c 6c 20 72 75 6e 6e 69 6e 67 22 s still running"
12ec0 29 0a 09 09 09 09 28 74 68 72 65 61 64 2d 73 6c ).....(thread-sl
12ed0 65 65 70 21 20 31 30 29 0a 09 09 09 09 28 6c 65 eep! 10).....(le
12ee0 74 20 28 28 6e 65 77 2d 74 65 73 74 73 20 28 70 t ((new-tests (p
12ef0 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 72 75 roc-get-tests ru
12f00 6e 2d 69 64 29 29 29 0a 09 09 09 09 20 20 28 69 n-id)))..... (i
12f10 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 2d 74 65 73 f (null? new-tes
12f20 74 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 ts)..... (d
12f30 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
12f40 31 20 22 52 75 6e 20 63 6f 6d 70 6c 65 74 65 64 1 "Run completed
12f50 20 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 7a 65 according to ze
12f60 72 6f 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e ro tests matchin
12f70 67 20 70 72 6f 76 69 64 65 64 20 63 72 69 74 65 g provided crite
12f80 72 69 61 2e 22 29 0a 09 09 09 09 20 20 20 20 20 ria.").....
12f90 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 2d (loop (car new-
12fa0 74 65 73 74 73 29 28 63 64 72 20 6e 65 77 2d 74 tests)(cdr new-t
12fb0 65 73 74 73 29 29 29 29 29 0a 09 09 09 20 20 20 ests)))))....
12fc0 20 20 20 20 28 28 61 72 63 68 69 76 65 29 0a 09 ((archive)..
12fd0 09 09 09 28 69 66 20 28 61 6e 64 20 72 75 6e 2d ...(if (and run-
12fe0 64 69 72 20 28 6e 6f 74 20 74 6f 70 6c 65 76 65 dir (not topleve
12ff0 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 65 6e 29 l-with-children)
13000 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 )..... (let (
13010 28 64 64 69 72 20 28 63 6f 6e 63 20 72 75 6e 2d (ddir (conc run-
13020 64 69 72 20 22 2f 22 29 29 29 0a 09 09 09 09 20 dir "/"))).....
13030 20 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 (case (stri
13040 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 61 72 67 73 ng->symbol (args
13050 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 63 68 69 :get-arg "-archi
13060 76 65 22 29 29 0a 09 09 09 09 09 28 28 73 61 76 ve"))......((sav
13070 65 20 73 61 76 65 2d 72 65 6d 6f 76 65 20 6b 65 e save-remove ke
13080 65 70 2d 68 74 6d 6c 29 0a 09 09 09 09 09 20 28 ep-html)...... (
13090 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
130a0 20 64 64 69 72 29 0a 09 09 09 09 09 20 20 20 20 ddir)......
130b0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
130c0 66 6f 20 30 20 22 45 73 74 69 6d 61 74 69 6e 67 fo 0 "Estimating
130d0 20 64 69 73 6b 20 73 70 61 63 65 20 75 73 61 67 disk space usag
130e0 65 20 66 6f 72 20 22 20 74 65 73 74 2d 66 75 6c e for " test-ful
130f0 6c 6e 20 22 3a 20 22 20 28 63 6f 6d 6d 6f 6e 3a ln ": " (common:
13100 67 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d 75 get-disk-space-u
13110 73 65 64 20 64 64 69 72 29 29 29 29 29 29 29 0a sed ddir))))))).
13120 09 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 ....(if (not (nu
13130 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 20 ll? tal)).....
13140 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
13150 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a 09 09 )(cdr tal))))...
13160 09 20 20 20 20 20 20 20 29 29 29 0a 09 09 20 20 . )))...
13170 20 20 20 20 20 29 0a 09 09 20 20 20 20 20 28 69 )... (i
13180 66 20 77 6f 72 6b 65 72 2d 74 68 72 65 61 64 20 f worker-thread
13190 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 77 6f (thread-join! wo
131a0 72 6b 65 72 2d 74 68 72 65 61 64 29 29 29 29 29 rker-thread)))))
131b0 29 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 ).. ;; remove
131c0 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 the run if zero
131d0 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 tests remain..
131e0 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 6f 6e (if (eq? action
131f0 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 'remove-runs)..
13200 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 (let ((re
13210 6d 74 65 73 74 73 20 28 6d 74 3a 67 65 74 2d 74 mtests (mt:get-t
13220 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 28 64 62 ests-for-run (db
13230 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
13240 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
13250 22 69 64 22 29 20 23 66 20 27 28 22 44 45 4c 45 "id") #f '("DELE
13260 54 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 6e TED") '("n/a") n
13270 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 20 ot-in: #t)))...
13280 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 (if (null? remte
13290 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 sts) ;; no more
132a0 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a tests remaining.
132b0 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 .. (let* ((d
132c0 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 parts (string-s
132d0 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 22 plit lasttpath "
132e0 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 6e /")).... (run
132f0 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 28 path (conc "/" (
13300 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
13310 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 20 se .......(take
13320 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 dparts (- (lengt
13330 68 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 09 h dparts) 1))...
13340 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 20 ...."/"))))...
13350 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
13360 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 t 1 "Removing ru
13370 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
13380 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
13390 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
133a0 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 20 er "runname") "
133b0 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 6f and related reco
133c0 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 72 rd")... (r
133d0 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 72 75 mt:delete-run ru
133e0 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 28 n-id)... (
133f0 72 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 rmt:delete-old-d
13400 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f eleted-test-reco
13410 72 64 73 29 0a 09 09 20 20 20 20 20 20 20 3b 3b rds)... ;;
13420 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 22 44 (rmt:set-var "D
13430 45 4c 45 54 45 44 5f 54 45 53 54 53 22 20 28 63 ELETED_TESTS" (c
13440 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
13450 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 ... ;; nee
13460 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 d to figure out
13470 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 the path to the
13480 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f run dir and remo
13490 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 ve it if empty..
134a0 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 69 . ;; (i
134b0 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 f (null? (glob (
134c0 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a conc runpath "/*
134d0 22 29 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b ")))... ;;
134e0 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
134f0 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 64 65 . ;; . (de
13500 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
13510 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 20 22 20 oving run dir "
13520 72 75 6e 70 61 74 68 29 0a 09 09 20 20 20 20 20 runpath)...
13530 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 ;; . (system (
13540 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 conc "rmdir -p "
13550 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 runpath))))...
13560 20 20 20 20 20 20 29 29 29 29 29 0a 09 20 29 29 ))))).. ))
13570 0a 20 20 20 20 20 72 75 6e 73 29 0a 20 20 20 20 . runs).
13580 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 ;; (sqlite3:fina
13590 6c 69 7a 65 21 20 28 64 62 3a 64 65 6c 61 79 2d lize! (db:delay-
135a0 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 29 if-busy tdbdat))
135b0 0a 20 20 20 20 29 0a 20 20 23 74 29 0a 0a 28 64 . ). #t)..(d
135c0 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 6d 6f efine (runs:remo
135d0 76 65 2d 74 65 73 74 2d 64 69 72 65 63 74 6f 72 ve-test-director
135e0 79 20 74 65 73 74 20 6d 6f 64 65 29 20 3b 3b 20 y test mode) ;;
135f0 72 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 remove-data-only
13600 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d ). (let* ((run-
13610 64 69 72 20 20 20 20 20 20 20 28 64 62 3a 74 65 dir (db:te
13620 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 st-get-rundir te
13630 73 74 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 64 st)) ;; run d
13640 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 20 6c ir is from the l
13650 69 6e 6b 20 74 72 65 65 0a 09 20 28 72 65 61 6c ink tree.. (real
13660 2d 64 69 72 20 20 20 20 20 20 28 69 66 20 28 66 -dir (if (f
13670 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d ile-exists? run-
13680 64 69 72 29 0a 09 09 09 20 20 20 20 28 72 65 73 dir).... (res
13690 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 olve-pathname ru
136a0 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 23 66 n-dir).... #f
136b0 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 6d 6f ))). (case mo
136c0 64 65 0a 20 20 20 20 20 20 28 28 72 65 6d 6f 76 de. ((remov
136d0 65 2d 64 61 74 61 2d 6f 6e 6c 79 29 28 6d 74 3a e-data-only)(mt:
136e0 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
136f0 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a tatus-by-id (db:
13700 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 test-get-run_id
13710 74 65 73 74 29 28 64 62 3a 74 65 73 74 2d 67 65 test)(db:test-ge
13720 74 2d 69 64 20 74 65 73 74 29 20 22 43 4c 45 41 t-id test) "CLEA
13730 4e 49 4e 47 22 20 22 4c 4f 43 4b 45 44 22 20 23 NING" "LOCKED" #
13740 66 29 29 0a 20 20 20 20 20 20 28 28 72 65 6d 6f f)). ((remo
13750 76 65 2d 61 6c 6c 29 20 20 20 20 20 20 28 6d 74 ve-all) (mt
13760 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
13770 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 status-by-id (db
13780 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 :test-get-run_id
13790 20 74 65 73 74 29 28 64 62 3a 74 65 73 74 2d 67 test)(db:test-g
137a0 65 74 2d 69 64 20 74 65 73 74 29 20 22 52 45 4d et-id test) "REM
137b0 4f 56 49 4e 47 22 20 22 4c 4f 43 4b 45 44 22 20 OVING" "LOCKED"
137c0 23 66 29 29 0a 20 20 20 20 20 20 28 28 61 72 63 #f)). ((arc
137d0 68 69 76 65 2d 72 65 6d 6f 76 65 29 20 20 28 6d hive-remove) (m
137e0 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
137f0 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 -status-by-id (d
13800 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 b:test-get-run_i
13810 64 20 74 65 73 74 29 28 64 62 3a 74 65 73 74 2d d test)(db:test-
13820 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 41 52 get-id test) "AR
13830 43 48 49 56 45 5f 52 45 4d 4f 56 49 4e 47 22 20 CHIVE_REMOVING"
13840 23 66 20 23 66 29 29 29 0a 20 20 20 20 28 64 65 #f #f))). (de
13850 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
13860 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "Attempting to
13870 72 65 6d 6f 76 65 20 22 20 28 69 66 20 72 65 61 remove " (if rea
13880 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 64 69 l-dir (conc " di
13890 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 r " real-dir " a
138a0 6e 64 20 22 29 20 22 22 29 20 22 20 6c 69 6e 6b nd ") "") " link
138b0 20 22 20 72 75 6e 2d 64 69 72 29 0a 20 20 20 20 " run-dir).
138c0 28 69 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 69 (if (and real-di
138d0 72 20 0a 09 20 20 20 20 20 28 3e 20 28 73 74 72 r .. (> (str
138e0 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 6c 2d ing-length real-
138f0 64 69 72 29 20 35 29 0a 09 20 20 20 20 20 28 66 dir) 5).. (f
13900 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c ile-exists? real
13910 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 68 65 -dir)) ;; bad he
13920 75 72 69 73 74 69 63 20 62 75 74 20 73 68 6f 75 uristic but shou
13930 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 ld prevent /tmp
13940 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 28 62 65 67 /home etc...(beg
13950 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 61 in ;; let* ((rea
13960 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d 70 lpath (resolve-p
13970 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 athname run-dir)
13980 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
13990 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 72 nt-info 1 "Recur
139a0 73 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 20 sively removing
139b0 22 20 72 65 61 6c 2d 64 69 72 29 0a 09 20 20 28 " real-dir).. (
139c0 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
139d0 20 72 65 61 6c 2d 64 69 72 29 0a 09 20 20 20 20 real-dir)..
139e0 20 20 28 72 75 6e 73 3a 73 61 66 65 2d 64 65 6c (runs:safe-del
139f0 65 74 65 2d 74 65 73 74 2d 64 69 72 20 72 65 61 ete-test-dir rea
13a00 6c 2d 64 69 72 29 0a 09 20 20 20 20 20 20 28 64 l-dir).. (d
13a10 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
13a20 52 4e 49 4e 47 3a 20 74 65 73 74 20 64 69 72 20 RNING: test dir
13a30 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 70 70 " real-dir " app
13a40 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 69 73 ears to not exis
13a50 74 20 6f 72 20 69 73 20 6e 6f 74 20 72 65 61 64 t or is not read
13a60 61 62 6c 65 22 29 29 29 0a 09 28 69 66 20 72 65 able")))..(if re
13a70 61 6c 2d 64 69 72 20 0a 09 20 20 20 20 28 64 65 al-dir .. (de
13a80 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
13a90 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 NING: directory
13aa0 22 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f 65 " real-dir " doe
13ab0 73 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 20 s not exist")..
13ac0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
13ad0 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 0 "WARNING: no r
13ae0 65 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 6f eal directory co
13af0 72 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c rrosponding to l
13b00 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 2c ink " run-dir ",
13b10 20 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 nothing done"))
13b20 29 0a 20 20 20 20 28 69 66 20 28 73 79 6d 62 6f ). (if (symbo
13b30 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 lic-link? run-di
13b40 72 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 r)..(begin.. (d
13b50 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
13b60 31 20 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 1 "Removing syml
13b70 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 ink " run-dir)..
13b80 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
13b90 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 ions.. exn..
13ba0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
13bb0 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 "ERROR: Failed
13bc0 74 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 6e to remove symlin
13bd0 6b 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f k " run-dir ((co
13be0 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
13bf0 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
13c00 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c message) exn) ",
13c10 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
13c20 6f 6e 74 69 6e 75 65 22 29 0a 09 20 20 20 28 64 ontinue").. (d
13c30 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d 64 elete-file run-d
13c40 69 72 29 29 29 0a 09 28 69 66 20 28 64 69 72 65 ir)))..(if (dire
13c50 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a ctory? run-dir).
13c60 09 20 20 20 20 28 69 66 20 28 3e 20 28 64 69 72 . (if (> (dir
13c70 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 6d ectory-fold (lam
13c80 62 64 61 20 28 66 20 78 29 28 2b 20 31 20 78 29 bda (f x)(+ 1 x)
13c90 29 20 30 20 72 75 6e 2d 64 69 72 29 20 30 29 0a ) 0 run-dir) 0).
13ca0 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
13cb0 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 "WARNING: refus
13cc0 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 ing to remove "
13cd0 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 run-dir " as it
13ce0 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 is not empty")..
13cf0 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
13d00 6f 6e 73 0a 09 09 20 65 78 6e 0a 09 09 20 28 64 ons... exn... (d
13d10 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
13d20 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 ROR: Failed to
13d30 72 65 6d 6f 76 65 20 64 69 72 65 63 74 6f 72 79 remove directory
13d40 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f 6e " run-dir ((con
13d50 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
13d60 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
13d70 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 essage) exn) ",
13d80 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6f attempting to co
13d90 6e 74 69 6e 75 65 22 29 0a 09 09 20 28 64 65 6c ntinue")... (del
13da0 65 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 75 ete-directory ru
13db0 6e 2d 64 69 72 29 29 29 0a 09 20 20 20 20 28 69 n-dir))).. (i
13dc0 66 20 28 61 6e 64 20 72 75 6e 2d 64 69 72 0a 09 f (and run-dir..
13dd0 09 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 . (not (memb
13de0 65 72 20 72 75 6e 2d 64 69 72 20 28 6c 69 73 74 er run-dir (list
13df0 20 22 6e 2f 61 22 20 22 2f 74 6d 70 2f 62 61 64 "n/a" "/tmp/bad
13e00 6e 61 6d 65 22 29 29 29 29 0a 09 09 28 64 65 62 name"))))...(deb
13e10 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
13e20 49 4e 47 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e ING: not removin
13e30 67 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 g " run-dir " as
13e40 20 69 74 20 65 69 74 68 65 72 20 64 6f 65 73 6e it either doesn
13e50 27 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 't exist or is n
13e60 6f 74 20 61 20 73 79 6d 6c 69 6e 6b 22 29 0a 09 ot a symlink")..
13e70 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
13e80 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 64 "NOTE: the run d
13e90 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 ir for this test
13ea0 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 54 is undefined. T
13eb0 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c 72 est may have alr
13ec0 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 65 eady been delete
13ed0 64 2e 22 29 29 0a 09 20 20 20 20 29 29 0a 20 20 d.")).. )).
13ee0 20 20 3b 3b 20 4f 6e 6c 79 20 64 65 6c 65 74 65 ;; Only delete
13ef0 20 74 68 65 20 72 65 63 6f 72 64 73 20 2a 61 66 the records *af
13f00 74 65 72 2a 20 72 65 6d 6f 76 69 6e 67 20 74 68 ter* removing th
13f10 65 20 64 69 72 65 63 74 6f 72 79 2e 20 49 66 20 e directory. If
13f20 74 68 69 6e 67 73 20 66 61 69 6c 20 77 65 20 68 things fail we h
13f30 61 76 65 20 61 20 72 65 63 6f 72 64 20 0a 20 20 ave a record .
13f40 20 20 28 63 61 73 65 20 6d 6f 64 65 0a 20 20 20 (case mode.
13f50 20 20 20 28 28 72 65 6d 6f 76 65 2d 64 61 74 61 ((remove-data
13f60 2d 6f 6e 6c 79 29 28 6d 74 3a 74 65 73 74 2d 73 -only)(mt:test-s
13f70 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
13f80 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 by-id (db:test-g
13f90 65 74 2d 72 75 6e 5f 69 64 20 74 65 73 74 29 28 et-run_id test)(
13fa0 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
13fb0 65 73 74 29 20 22 4e 4f 54 5f 53 54 41 52 54 45 est) "NOT_STARTE
13fc0 44 22 20 22 6e 2f 61 22 20 23 66 29 29 0a 20 20 D" "n/a" #f)).
13fd0 20 20 20 20 28 28 61 72 63 68 69 76 65 2d 72 65 ((archive-re
13fe0 6d 6f 76 65 29 20 20 28 6d 74 3a 74 65 73 74 2d move) (mt:test-
13ff0 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
14000 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 2d -by-id (db:test-
14010 67 65 74 2d 72 75 6e 5f 69 64 20 74 65 73 74 29 get-run_id test)
14020 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
14030 74 65 73 74 29 20 22 41 52 43 48 49 56 45 44 22 test) "ARCHIVED"
14040 20 23 66 20 23 66 29 29 0a 20 20 20 20 20 20 28 #f #f)). (
14050 65 6c 73 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 else (rmt:delete
14060 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 28 64 -test-records (d
14070 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 b:test-get-run_i
14080 64 20 74 65 73 74 29 20 28 64 62 3a 74 65 73 74 d test) (db:test
14090 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 29 29 -get-id test))))
140a0 29 29 0a 0a 3b 3b 3d 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 0a 3b 3b 20 ============.;;
140f0 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e Routines for man
14100 69 70 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b ipulating runs.;
14110 3b 3d 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 0a 0a 3b 3b 20 53 69 6e 63 =======..;; Sinc
14160 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 e many calls to
14170 61 20 72 75 6e 20 72 65 71 75 69 72 65 20 70 72 a run require pr
14180 65 74 74 79 20 6d 75 63 68 20 74 68 65 20 73 61 etty much the sa
14190 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 me setup .;; thi
141a0 73 20 77 72 61 70 70 65 72 20 69 73 20 75 73 65 s wrapper is use
141b0 64 20 74 6f 20 72 65 64 75 63 65 20 74 68 65 20 d to reduce the
141c0 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 replication of c
141d0 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 67 65 6e ode.(define (gen
141e0 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 eral-run-call sw
141f0 69 74 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d itchname action-
14200 64 65 73 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 desc proc). (le
14210 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 6f 72 20 t ((runname (or
14220 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
14230 72 75 6e 6e 61 6d 65 22 29 28 61 72 67 73 3a 67 runname")(args:g
14240 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
14250 22 29 29 29 0a 09 28 74 61 72 67 65 74 20 20 28 ")))..(target (
14260 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d common:args-get-
14270 74 61 72 67 65 74 29 29 29 0a 20 20 20 20 28 63 target))). (c
14280 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 ond. ((not t
14290 61 72 67 65 74 29 0a 20 20 20 20 20 20 28 64 65 arget). (de
142a0 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
142b0 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
142c0 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
142d0 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
142e0 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
142f0 69 66 79 20 74 68 65 20 74 61 72 67 65 74 20 77 ify the target w
14300 69 74 68 20 2d 74 61 72 67 65 74 22 29 0a 20 20 ith -target").
14310 20 20 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 (exit 3)).
14320 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 ((not runname
14330 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
14340 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d rint 0 "ERROR: M
14350 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 issing required
14360 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 parameter for "
14370 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f switchname ", yo
14380 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 u must specify t
14390 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 he run name with
143a0 20 2d 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d -runname runnam
143b0 65 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 e"). (exit
143c0 33 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 3)). (else.
143d0 20 20 20 20 20 28 6c 65 74 20 28 3b 3b 20 28 64 (let (;; (d
143e0 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b 65 b #f).. (ke
143f0 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 6c 61 ys #f))..(if (la
14400 75 6e 63 68 3a 73 65 74 75 70 2d 66 6f 72 2d 72 unch:setup-for-r
14410 75 6e 29 0a 09 20 20 20 20 28 6c 61 75 6e 63 68 un).. (launch
14420 3a 63 61 63 68 65 2d 63 6f 6e 66 69 67 29 0a 09 :cache-config)..
14430 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 (begin ..
14440 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
14450 30 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 0 "Failed to set
14460 75 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 up, exiting")..
14470 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a (exit 1))).
14480 09 28 73 65 74 21 20 6b 65 79 73 20 28 6b 65 79 .(set! keys (key
14490 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 s:config-get-fie
144a0 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 lds *configdat*)
144b0 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 )..;; have enoug
144c0 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 h to process -ta
144d0 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 rget or -reqtarg
144e0 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 here..(if (args
144f0 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
14500 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 rg").. (let*
14510 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f ((runconfigf (co
14520 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
14530 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
14540 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 g")) ;; DO NOT E
14550 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 VALUATE ALL ...
14560 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 (runconfig (r
14570 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f ead-config runco
14580 6e 66 69 67 66 20 23 66 20 23 74 20 65 6e 76 69 nfigf #f #t envi
14590 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 0a ron-patt: #f))).
145a0 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 68 . (if (hash
145b0 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
145c0 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 lt runconfig (ar
145d0 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
145e0 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 targ") #f)... (
145f0 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d keys:target-set-
14600 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a args keys (args:
14610 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
14620 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 g") args:arg-has
14630 68 29 0a 09 09 20 20 20 20 0a 09 09 20 20 28 62 h)... ... (b
14640 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 egin... (debu
14650 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
14660 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 : [" (args:get-a
14670 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 rg "-reqtarg") "
14680 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 ] not found in "
14690 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 runconfigf)...
146a0 20 20 20 3b 3b 20 28 69 66 20 64 62 20 28 73 71 ;; (if db (sq
146b0 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
146c0 64 62 29 29 0a 09 09 20 20 20 20 28 65 78 69 74 db))... (exit
146d0 20 31 29 0a 09 09 20 20 20 20 29 29 29 0a 09 20 1)... )))..
146e0 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
146f0 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
14700 09 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 ..(keys:target-s
14710 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 et-args keys (ar
14720 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
14730 67 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 61 get" args:arg-ha
14740 73 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 sh) args:arg-has
14750 68 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 h)))..(if (not (
14760 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a car *configinfo*
14770 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
14780 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
14790 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 74 nt 0 "ERROR: Att
147a0 65 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 69 empted to " acti
147b0 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 75 on-desc " but ru
147c0 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 69 n area config fi
147d0 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 le not found")..
147e0 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a (exit 1)).
147f0 09 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 20 . ;; Extract
14800 6f 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 64 out stuff needed
14810 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 in most or many
14820 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 calls.. ;; h
14830 65 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 ere then call pr
14840 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 oc.. (let* ((
14850 6b 65 79 76 61 6c 73 20 20 20 20 28 6b 65 79 73 keyvals (keys
14860 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
14870 6b 65 79 73 20 74 61 72 67 65 74 29 29 29 0a 09 keys target)))..
14880 20 20 20 20 20 20 28 70 72 6f 63 20 74 61 72 67 (proc targ
14890 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 79 73 20 et runname keys
148a0 6b 65 79 76 61 6c 73 29 29 29 0a 09 3b 3b 20 28 keyvals)))..;; (
148b0 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 if db (sqlite3:f
148c0 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 28 inalize! db))..(
148d0 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 set! *didsomethi
148e0 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b 3b ng* #t))))))..;;
148f0 3d 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 0a 3b 3b 20 4c 6f 63 6b 2f 75 ======.;; Lock/u
14940 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d 3d nlock 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 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 ===..(define (ru
149a0 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 6e ns:handle-lockin
149b0 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 75 g target keys ru
149c0 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f 63 nname lock unloc
149d0 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 k user). (let*
149e0 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a 09 ((db #f)..
149f0 20 28 72 75 6e 64 61 74 20 20 20 28 6d 74 3a 67 (rundat (mt:g
14a00 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 et-runs-by-patt
14a10 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 74 61 72 keys runname tar
14a20 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 72 20 get)).. (header
14a30 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
14a40 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 ndat 0)).. (runs
14a50 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
14a60 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 20 20 rundat 1))).
14a70 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
14a80 64 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 74 20 da (run)...(let
14a90 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 ((run-id (db:get
14aa0 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
14ab0 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
14ac0 29 29 29 0a 09 09 20 20 28 69 66 20 28 6f 72 20 )))... (if (or
14ad0 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 20 75 lock.... (and u
14ae0 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 20 20 nlock....
14af0 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 72 69 (begin..... (pri
14b00 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 61 6c 6c nt "Do you reall
14b10 79 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f 63 6b y wish to unlock
14b20 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 3f run " run-id "?
14b30 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 09 09 \n y/n: ")....
14b40 09 20 28 65 71 75 61 6c 3f 20 22 79 22 20 28 72 . (equal? "y" (r
14b50 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 09 ead-line)))))...
14b60 20 20 20 20 20 20 28 72 6d 74 3a 6c 6f 63 6b 2f (rmt:lock/
14b70 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d 69 unlock-run run-i
14b80 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 d lock unlock us
14b90 65 72 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 er)... (deb
14ba0 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
14bb0 22 53 6b 69 70 70 69 6e 67 20 6c 6f 63 6b 2f 75 "Skipping lock/u
14bc0 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 6e 2d 69 nlock on " run-i
14bd0 64 29 29 29 29 0a 09 20 20 20 20 20 20 72 75 6e d)))).. run
14be0 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d s))).;;=========
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 0a 3b 3b =============.;;
14c30 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 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 0a 0a 3b 3b 20 55 70 64 61 74 65 =====..;; Update
14c90 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 the test_meta t
14ca0 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 74 65 able for this te
14cb0 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 st.(define (runs
14cc0 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
14cd0 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 a test-name test
14ce0 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 -conf). (let ((
14cf0 63 75 72 72 72 65 63 6f 72 64 20 28 72 6d 74 3a currrecord (rmt:
14d00 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 testmeta-get-rec
14d10 6f 72 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ord test-name)))
14d20 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 . (if (not cu
14d30 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 rrrecord)..(begi
14d40 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 72 n.. (set! currr
14d50 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 ecord (make-vect
14d60 6f 72 20 31 31 20 23 66 29 29 0a 09 20 20 28 72 or 11 #f)).. (r
14d70 6d 74 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d mt:testmeta-add-
14d80 72 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d 65 record test-name
14d90 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
14da0 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
14db0 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 6c 65 (key). (le
14dc0 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 20 6b t* ((idx (cadr k
14dd0 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 6c 64 ey)).. (fld
14de0 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 20 20 (car key))..
14df0 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 (val (config
14e00 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e -lookup test-con
14e10 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 66 6c f "test_meta" fl
14e20 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 d))).. ;; (debug
14e30 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a 20 22 :print 5 "idx: "
14e40 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 66 6c idx " fld: " fl
14e50 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a d " val: " val).
14e60 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c 20 28 . (if (and val (
14e70 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 65 63 not (equal? (vec
14e80 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 63 6f tor-ref currreco
14e90 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 0a 09 rd idx) val)))..
14ea0 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
14eb0 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 64 61 (print "Upda
14ec0 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 ting " test-name
14ed0 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 22 20 " " fld " to "
14ee0 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 72 6d val).. (rm
14ef0 74 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 t:testmeta-updat
14f00 65 2d 66 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d e-field test-nam
14f10 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 e fld val))))).
14f20 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 '(("author"
14f30 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 2)("owner" 3)("d
14f40 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 escription" 4)("
14f50 72 65 76 69 65 77 65 64 22 20 35 29 28 22 74 61 reviewed" 5)("ta
14f60 67 73 22 20 39 29 28 22 6a 6f 62 67 72 6f 75 70 gs" 9)("jobgroup
14f70 22 20 31 30 29 29 29 29 29 0a 0a 3b 3b 20 55 70 " 10)))))..;; Up
14f80 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 date test_meta f
14f90 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 or all tests.(de
14fa0 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 fine (runs:updat
14fb0 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 e-all-test_meta
14fc0 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 db). (let ((tes
14fd0 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 67 t-names (tests:g
14fe0 65 74 2d 61 6c 6c 29 29 29 20 3b 3b 20 28 74 65 et-all))) ;; (te
14ff0 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
15000 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d sts))). (for-
15010 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
15020 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 da (test-name).
15030 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
15040 73 74 2d 63 6f 6e 66 20 20 20 20 28 6d 74 3a 6c st-conf (mt:l
15050 61 7a 79 2d 72 65 61 64 2d 74 65 73 74 2d 63 6f azy-read-test-co
15060 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 29 29 nfig test-name))
15070 29 0a 09 20 28 69 66 20 74 65 73 74 2d 63 6f 6e ).. (if test-con
15080 66 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 f (runs:update-t
15090 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 est_meta test-na
150a0 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 29 me test-conf))))
150b0 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
150c0 65 2d 6b 65 79 73 20 74 65 73 74 2d 6e 61 6d 65 e-keys test-name
150d0 73 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 s))))..;; This c
150e0 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 ould probably be
150f0 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f refactored into
15100 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 one complex que
15110 72 79 20 2e 2e 2e 0a 3b 3b 20 4e 4f 54 20 50 4f ry ....;; NOT PO
15120 52 54 45 44 20 2d 20 44 4f 20 4e 4f 54 20 55 53 RTED - DO NOT US
15130 45 20 59 45 54 0a 3b 3b 0a 28 64 65 66 69 6e 65 E YET.;;.(define
15140 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 (runs:rollup-ru
15150 6e 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 75 n keys runname u
15160 73 65 72 20 6b 65 79 76 61 6c 73 29 0a 20 20 28 ser keyvals). (
15170 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 debug:print 4 "r
15180 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 uns:rollup-run,
15190 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 2d keys: " keys " -
151a0 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d runname " runnam
151b0 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 e " user: " user
151c0 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 ). (let* ((db
151d0 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
151e0 09 20 3b 3b 20 72 65 67 69 73 74 65 72 20 72 75 . ;; register ru
151f0 6e 20 6f 70 65 72 61 74 65 73 20 6f 6e 20 74 68 n operates on th
15200 65 20 6d 61 69 6e 20 64 62 0a 09 20 28 6e 65 77 e main db.. (new
15210 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 6d -run-id (rm
15220 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 6b t:register-run k
15230 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 22 eyvals runname "
15240 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 new" "n/a" user)
15250 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 20 ).. (prev-tests
15260 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6d 61 (rmt:get-ma
15270 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d tching-previous-
15280 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 test-run-records
15290 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 new-run-id "%"
152a0 22 25 22 29 29 0a 09 20 28 63 75 72 72 2d 74 65 "%")).. (curr-te
152b0 73 74 73 20 20 20 20 20 20 28 6d 74 3a 67 65 74 sts (mt:get
152c0 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e -tests-for-run n
152d0 65 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 ew-run-id "%/%"
152e0 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 72 '() '())).. (cur
152f0 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d 61 r-tests-hash (ma
15300 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
15310 0a 20 20 20 20 28 72 6d 74 3a 75 70 64 61 74 65 . (rmt:update
15320 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -run-event_time
15330 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 new-run-id).
15340 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c 72 ;; index the alr
15350 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 73 eady saved tests
15360 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 by testname and
15370 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 72 itemdat in curr
15380 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 20 -tests-hash.
15390 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
153a0 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
153b0 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
153c0 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 testname (db:te
153d0 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
153e0 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
153f0 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
15400 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
15410 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 th testdat))..
15420 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
15430 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
15440 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
15450 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
15460 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 ! curr-tests-has
15470 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 h full-name test
15480 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 72 dat))). curr
15490 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e -tests). ;; N
154a0 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c OPE: Non-optimal
154b0 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 74 approach. Try t
154c0 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 his instead..
154d0 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 61 ;; 1. tests a
154e0 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 61 re received in a
154f0 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 list, most rece
15500 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 nt first. ;;
15510 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 65 2. replace the
15520 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 74 rollup test wit
15530 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 h the new *alway
15540 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s*. (for-each
15550 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
15560 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
15570 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
15580 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 (db:test-get-t
15590 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
155a0 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
155b0 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
155c0 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 -item-path testd
155d0 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c at)).. (ful
155e0 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 l-name (conc tes
155f0 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
15600 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 72 ath)).. (pr
15610 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 73 ev-test-dat (has
15620 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
15630 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d 68 ult curr-tests-h
15640 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 ash full-name #f
15650 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
15660 73 74 65 70 73 20 20 20 20 28 72 6d 74 3a 67 65 steps (rmt:ge
15670 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 t-steps-for-test
15680 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
15690 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 20 testdat)))..
156a0 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 (new-test-rec
156b0 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 ord #f)).. ;; re
156c0 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 68 place these with
156d0 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 insert ... sele
156e0 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c 69 ct.. (apply sqli
156f0 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 64 te3:execute ...d
15700 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 b ...(conc "INSE
15710 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e RT OR REPLACE IN
15720 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 TO tests (run_id
15730 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c ,testname,state,
15740 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d status,event_tim
15750 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 e,host,cpuload,d
15760 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 iskfree,uname,ru
15770 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 ndir,item_path,r
15780 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 un_duration,fina
15790 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 l_logf,comment)
157a0 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 45 "... "VALUE
157b0 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f S (?,?,?,?,?,?,?
157c0 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b ,?,?,?,?,?,?,?);
157d0 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 ")...new-run-id
157e0 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c (cddr (vector->l
157f0 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a 09 ist testdat)))..
15800 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 64 (set! new-testd
15810 61 74 20 28 63 61 72 20 28 6d 74 3a 67 65 74 2d at (car (mt:get-
15820 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e 65 tests-for-run ne
15830 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 74 w-run-id (conc t
15840 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d estname "/" item
15850 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 29 29 -path) '() '()))
15860 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ).. (hash-table-
15870 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d set! curr-tests-
15880 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e hash full-name n
15890 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 ew-testdat) ;; t
158a0 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e his could be con
158b0 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 fusing, which re
158c0 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 cord should go i
158d0 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 nto the lookup t
158e0 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 able?.. ;; Now d
158f0 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 uplicate the tes
15900 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 t steps.. (debug
15910 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e :print 4 "Copyin
15920 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 g records in tes
15930 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 t_steps from tes
15940 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d t_id=" (db:test-
15950 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 get-id testdat)
15960 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d " to " (db:test-
15970 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
15980 61 74 29 29 0a 09 20 28 63 64 62 3a 72 65 6d 6f at)).. (cdb:remo
15990 74 65 2d 72 75 6e 20 3b 3b 20 74 6f 20 62 65 20 te-run ;; to be
159a0 72 65 70 6c 61 63 65 64 2c 20 6e 6f 74 65 3a 20 replaced, note:
159b0 74 68 69 73 20 72 6f 75 74 69 6e 65 20 69 73 20 this routine is
159c0 6e 6f 74 20 75 73 65 64 20 63 75 72 72 65 6e 74 not used current
159d0 6c 79 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 29 ly.. (lambda ()
159e0 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 .. (sqlite3:e
159f0 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 62 xecute .. db
15a00 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 49 .. (conc "I
15a10 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
15a20 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 73 INTO test_steps
15a30 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 (test_id,stepna
15a40 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
15a50 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 event_time,comme
15a60 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 nt) "... "SELE
15a70 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 CT " (db:test-ge
15a80 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
15a90 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 ) ",stepname,sta
15aa0 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f te,status,event_
15ab0 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f time,comment FRO
15ac0 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 45 M test_steps WHE
15ad0 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a RE test_id=?;").
15ae0 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 . (db:test-g
15af0 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
15b00 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 6c . ;; Now dupl
15b10 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 64 icate the test d
15b20 61 74 61 0a 09 20 20 20 20 28 64 65 62 75 67 3a ata.. (debug:
15b30 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 print 4 "Copying
15b40 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 records in test
15b50 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 5f _data from test_
15b60 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 id=" (db:test-ge
15b70 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 t-id testdat) "
15b80 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 to " (db:test-ge
15b90 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
15ba0 29 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 )).. (sqlite3
15bb0 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 :execute ..
15bc0 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 db .. (conc
15bd0 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
15be0 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 CE INTO test_dat
15bf0 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 a (test_id,categ
15c00 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c ory,variable,val
15c10 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c ue,expected,tol,
15c20 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 units,comment) "
15c30 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 ... "SELECT "
15c40 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
15c50 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 63 new-testdat) ",c
15c60 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 ategory,variable
15c70 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c ,value,expected,
15c80 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e tol,units,commen
15c90 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 t FROM test_data
15ca0 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f WHERE test_id=?
15cb0 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 ;").. (db:te
15cc0 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
15cd0 74 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 t)))).. )).
15ce0 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 20 prev-tests)))..
15cf0 0a 20 20 20 20 20 0a . .