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 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d )..(include "com
02d0: 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 mon_records.scm"
02e0: 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b 65 79 5f ).(include "key_
02f0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
0300: 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 nclude "db_recor
0310: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0320: 65 20 22 72 75 6e 5f 72 65 63 6f 72 64 73 2e 73 e "run_records.s
0330: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 74 cm").(include "t
0340: 65 73 74 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 est_records.scm"
0350: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
0360: 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 2d 70 :test-get-full-p
0370: 61 74 68 20 74 65 73 74 29 0a 20 20 28 6c 65 74 ath test). (let
0380: 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 28 64 62 * ((testname (db
0390: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
03a0: 6d 65 20 20 20 74 65 73 74 29 29 0a 09 20 28 69 me test)).. (i
03b0: 74 65 6d 70 61 74 68 20 28 64 62 3a 74 65 73 74 tempath (db:test
03c0: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
03d0: 65 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 est))). (conc
03e0: 20 74 65 73 74 6e 61 6d 65 20 28 69 66 20 28 65 testname (if (e
03f0: 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 20 22 qual? itempath "
0400: 22 29 20 22 22 20 28 63 6f 6e 63 20 22 28 22 20 ") "" (conc "("
0410: 69 74 65 6d 70 61 74 68 20 22 29 22 29 29 29 29 itempath ")"))))
0420: 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 74 68 )..;; This is th
0430: 65 20 2a 6e 65 77 2a 20 6d 65 74 68 6f 64 6f 6c e *new* methodol
0440: 6f 67 79 2e 20 4f 6e 65 20 72 65 63 6f 72 64 20 ogy. One record
0450: 74 6f 20 69 6e 66 6f 72 6d 20 74 68 65 6d 20 61 to inform them a
0460: 6e 64 20 69 6e 20 74 68 65 20 63 68 61 6f 73 2c nd in the chaos,
0470: 20 6f 72 67 61 6e 69 73 65 20 74 68 65 6d 2e 0a organise them..
0480: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 ;;.(define (runs
0490: 3a 63 72 65 61 74 65 2d 72 75 6e 2d 72 65 63 6f :create-run-reco
04a0: 72 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 6d 63 rd). (let* ((mc
04b0: 6f 6e 66 69 67 20 20 20 20 20 20 28 69 66 20 2a onfig (if *
04c0: 63 6f 6e 66 69 67 64 61 74 2a 0a 09 09 20 20 20 configdat*...
04d0: 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 *configd
04e0: 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 20 20 at*...
04f0: 20 28 69 66 20 28 73 65 74 75 70 2d 66 6f 72 2d (if (setup-for-
0500: 72 75 6e 29 0a 09 09 20 20 20 20 20 20 20 20 20 run)...
0510: 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 *configdat
0520: 2a 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 20 *...
0530: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
0540: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
0550: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
0560: 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 74 75 70 OR: Called setup
0570: 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 61 74 65 in a non-megate
0580: 73 74 20 61 72 65 61 2c 20 65 78 69 74 69 6e 67 st area, exiting
0590: 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 ")...
05a0: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
05b0: 29 29 0a 09 20 20 28 72 75 6e 72 65 63 20 20 20 )).. (runrec
05c0: 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 65 63 2d (runs:runrec-
05d0: 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 0a 09 20 make-record))..
05e0: 20 28 74 61 72 67 65 74 20 20 20 20 20 20 28 6f (target (o
05f0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
0600: 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 20 20 "-reqtarg")...
0610: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 (args:g
0620: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
0630: 29 29 29 0a 09 20 20 28 72 75 6e 6e 61 6d 65 20 ))).. (runname
0640: 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 (or (args:ge
0650: 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 t-arg ":runname"
0660: 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 28 )... (
0670: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
0680: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 20 20 28 74 unname"))).. (t
0690: 65 73 74 70 61 74 74 20 20 20 20 28 6f 72 20 28 estpatt (or (
06a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
06b0: 65 73 74 70 61 74 74 22 29 0a 09 09 20 20 20 20 estpatt")...
06c0: 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 (args:get
06d0: 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 -arg "-runtests"
06e0: 29 29 29 0a 09 20 20 28 6b 65 79 73 20 20 20 20 ))).. (keys
06f0: 20 20 20 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 (keys:config
0700: 2d 67 65 74 2d 66 69 65 6c 64 73 20 6d 63 6f 6e -get-fields mcon
0710: 66 69 67 29 29 0a 09 20 20 28 6b 65 79 76 61 6c fig)).. (keyval
0720: 73 20 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 s (keys:targ
0730: 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 et->keyval keys
0740: 74 61 72 67 65 74 29 29 0a 09 20 20 28 74 6f 70 target)).. (top
0750: 70 61 74 68 20 20 20 20 20 2a 74 6f 70 70 61 74 path *toppat
0760: 68 2a 29 0a 09 20 20 28 65 6e 76 64 61 74 20 20 h*).. (envdat
0770: 20 20 20 20 6b 65 79 76 61 6c 73 29 20 3b 3b 20 keyvals) ;;
0780: 69 6e 69 74 69 61 6c 20 76 61 6c 75 65 73 20 73 initial values s
0790: 74 61 72 74 20 77 69 74 68 20 6b 65 79 76 61 6c tart with keyval
07a0: 73 0a 09 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 s.. (runconfig
07b0: 20 20 23 66 29 0a 09 20 20 28 73 65 72 76 65 72 #f).. (server
07c0: 64 61 74 20 20 20 28 69 66 20 28 61 72 67 73 3a dat (if (args:
07d0: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
07e0: 22 29 0a 09 09 09 20 20 20 2a 72 75 6e 72 65 6d ").... *runrem
07f0: 6f 74 65 2a 0a 09 09 09 20 20 20 23 66 29 29 20 ote*.... #f))
0800: 3b 3b 20 74 6f 20 62 65 20 75 73 65 64 20 6c 61 ;; to be used la
0810: 74 65 72 0a 09 20 20 28 74 72 61 6e 73 70 6f 72 ter.. (transpor
0820: 74 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 t (or (args:ge
0830: 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 6f 72 t-arg "-transpor
0840: 74 22 29 20 27 68 74 74 70 29 29 0a 09 20 20 28 t") 'http)).. (
0850: 64 62 20 20 20 20 20 20 20 20 20 20 28 69 66 20 db (if
0860: 28 61 6e 64 20 6d 63 6f 6e 66 69 67 0a 09 09 09 (and mconfig....
0870: 09 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 .(or (args:get-a
0880: 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 09 rg "-server")...
0890: 09 09 20 20 20 20 28 65 71 3f 20 74 72 61 6e 73 .. (eq? trans
08a0: 70 6f 72 74 20 27 66 73 29 29 29 0a 09 09 09 20 port 'fs)))....
08b0: 20 20 28 6f 70 65 6e 2d 64 62 29 0a 09 09 09 20 (open-db)....
08c0: 20 20 23 66 29 29 0a 09 20 20 28 72 75 6e 2d 69 #f)).. (run-i
08d0: 64 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 d #f)).
08e0: 3b 3b 20 53 65 74 20 61 6c 6c 20 74 68 65 20 65 ;; Set all the e
08f0: 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 73 20 nvironment vars
0900: 77 65 20 6b 6e 6f 77 20 73 6f 20 66 61 72 2c 20 we know so far,
0910: 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 73 0a start with keys.
0920: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
0930: 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 ambda (keyval)..
0940: 09 28 73 65 74 65 6e 76 20 28 63 61 72 20 6b 65 .(setenv (car ke
0950: 79 76 61 6c 29 28 63 61 64 72 20 6b 65 79 76 61 yval)(cadr keyva
0960: 6c 29 29 29 0a 09 20 20 20 20 20 20 6b 65 79 76 l))).. keyv
0970: 61 6c 73 29 0a 20 20 20 20 3b 3b 20 53 65 74 20 als). ;; Set
0980: 75 70 20 76 61 72 69 6f 75 73 20 61 6e 64 20 73 up various and s
0990: 75 6e 64 72 79 20 6b 6e 6f 77 6e 20 76 61 72 73 undry known vars
09a0: 20 68 65 72 65 0a 20 20 20 20 28 73 65 74 65 6e here. (seten
09b0: 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 v "MT_RUN_AREA_H
09c0: 4f 4d 45 22 20 74 6f 70 70 61 74 68 29 0a 20 20 OME" toppath).
09d0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
09e0: 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 0a NNAME" runname).
09f0: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f (setenv "MT_
0a00: 54 41 52 47 45 54 22 20 20 74 61 72 67 65 74 29 TARGET" target)
0a10: 0a 20 20 20 20 28 73 65 74 21 20 65 6e 76 64 61 . (set! envda
0a20: 74 20 28 61 70 70 65 6e 64 20 0a 09 09 20 20 65 t (append ... e
0a30: 6e 76 64 61 74 0a 09 09 20 20 28 6c 69 73 74 20 nvdat... (list
0a40: 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 5f 41 52 (list "MT_RUN_AR
0a50: 45 41 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 EA_HOME" toppath
0a60: 29 0a 09 09 09 28 6c 69 73 74 20 22 4d 54 5f 52 )....(list "MT_R
0a70: 55 4e 4e 41 4d 45 22 20 20 20 20 20 20 20 72 75 UNNAME" ru
0a80: 6e 6e 61 6d 65 29 0a 09 09 09 28 6c 69 73 74 20 nname)....(list
0a90: 22 4d 54 5f 54 41 52 47 45 54 22 20 20 20 20 20 "MT_TARGET"
0aa0: 20 20 20 74 61 72 67 65 74 29 29 29 29 0a 20 20 target)))).
0ab0: 20 20 3b 3b 20 4e 6f 77 20 63 61 6e 20 72 65 61 ;; Now can rea
0ac0: 64 20 74 68 65 20 72 75 6e 63 6f 6e 66 69 67 73 d the runconfigs
0ad0: 20 66 69 6c 65 0a 20 20 20 20 3b 3b 20 0a 20 20 file. ;; .
0ae0: 20 20 28 73 65 74 21 20 72 75 6e 63 6f 6e 66 69 (set! runconfi
0af0: 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 g (read-config (
0b00: 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 conc *toppath*
0b10: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
0b20: 66 69 67 22 29 20 23 66 20 23 74 20 73 65 63 74 fig") #f #t sect
0b30: 69 6f 6e 73 3a 20 28 6c 69 73 74 20 22 64 65 66 ions: (list "def
0b40: 61 75 6c 74 22 20 74 61 72 67 65 74 29 29 29 0a ault" target))).
0b50: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
0b60: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0b70: 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 ault runconfig (
0b80: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
0b90: 65 71 74 61 72 67 22 29 20 23 66 29 29 0a 09 28 eqtarg") #f))..(
0ba0: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
0bb0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
0bc0: 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
0bd0: 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
0be0: 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
0bf0: 75 6e 63 6f 6e 66 69 67 66 29 0a 09 20 20 28 69 unconfigf).. (i
0c00: 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 f db (sqlite3:fi
0c10: 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 20 20 nalize! db))..
0c20: 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 3b (exit 1))). ;
0c30: 3b 20 4e 6f 77 20 68 61 76 65 20 72 75 6e 63 6f ; Now have runco
0c40: 6e 66 69 67 73 20 64 61 74 61 20 6c 6f 61 64 65 nfigs data loade
0c50: 64 2c 20 73 65 74 20 65 6e 76 69 72 6f 6e 6d 65 d, set environme
0c60: 6e 74 20 76 61 72 73 0a 20 20 20 20 28 66 6f 72 nt vars. (for
0c70: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 -each (lambda (s
0c80: 65 63 74 69 6f 6e 29 0a 09 09 28 66 6f 72 2d 65 ection)...(for-e
0c90: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 ach (lambda (var
0ca0: 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 val).... (set
0cb0: 21 20 65 6e 76 64 61 74 20 28 61 70 70 65 6e 64 ! envdat (append
0cc0: 20 65 6e 76 64 61 74 20 28 6c 69 73 74 20 76 61 envdat (list va
0cd0: 72 76 61 6c 29 29 29 0a 09 09 09 20 20 20 20 28 rval))).... (
0ce0: 73 65 74 65 6e 76 20 28 63 61 72 20 76 61 72 76 setenv (car varv
0cf0: 61 6c 29 28 63 61 64 72 20 76 61 72 76 61 6c 29 al)(cadr varval)
0d00: 29 29 0a 09 09 09 20 20 28 63 6f 6e 66 69 67 66 )).... (configf
0d10: 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 72 75 6e :get-section run
0d20: 63 6f 6e 66 69 67 20 73 65 63 74 69 6f 6e 29 29 config section))
0d30: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 22 ).. (list "
0d40: 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 29 default" target)
0d50: 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 74 61 ). (vector ta
0d60: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 rget runname tes
0d70: 74 70 61 74 74 20 6b 65 79 73 20 6b 65 79 76 61 tpatt keys keyva
0d80: 6c 73 20 65 6e 76 64 61 74 20 6d 63 6f 6e 66 69 ls envdat mconfi
0d90: 67 20 72 75 6e 63 6f 6e 66 69 67 20 73 65 72 76 g runconfig serv
0da0: 65 72 64 61 74 20 74 72 61 6e 73 70 6f 72 74 20 erdat transport
0db0: 64 62 20 74 6f 70 70 61 74 68 20 72 75 6e 2d 69 db toppath run-i
0dc0: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 d)))..(define (s
0dd0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
0de0: 76 61 72 73 20 72 75 6e 2d 69 64 20 23 21 6b 65 vars run-id #!ke
0df0: 79 20 28 69 6e 6b 65 79 73 20 23 66 29 28 69 6e y (inkeys #f)(in
0e00: 72 75 6e 6e 61 6d 65 20 23 66 29 28 69 6e 6b 65 runname #f)(inke
0e10: 79 76 61 6c 73 20 23 66 29 29 0a 20 20 28 6c 65 yvals #f)). (le
0e20: 74 2a 20 28 28 74 61 72 67 65 74 20 20 20 20 20 t* ((target
0e30: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
0e40: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 rg "-reqtarg")..
0e50: 09 09 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 .. (args:get-ar
0e60: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 09 g "-target")....
0e70: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
0e80: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
0e90: 54 41 52 47 45 54 22 29 29 29 0a 09 20 28 6b 65 TARGET"))).. (ke
0ea0: 79 73 20 20 20 20 28 69 66 20 69 6e 6b 65 79 73 ys (if inkeys
0eb0: 20 20 20 20 69 6e 6b 65 79 73 20 20 20 20 28 63 inkeys (c
0ec0: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
0ed0: 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 29 0a :get-keys #f))).
0ee0: 09 20 28 6b 65 79 76 61 6c 73 20 28 69 66 20 69 . (keyvals (if i
0ef0: 6e 6b 65 79 76 61 6c 73 20 69 6e 6b 65 79 76 61 nkeyvals inkeyva
0f00: 6c 73 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d ls (keys:target-
0f10: 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 >keyval keys tar
0f20: 67 65 74 29 29 29 0a 09 20 28 76 61 6c 73 20 28 get))).. (vals (
0f30: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0f40: 65 66 61 75 6c 74 20 2a 65 6e 76 2d 76 61 72 73 efault *env-vars
0f50: 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d -by-run-id* run-
0f60: 69 64 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 id #f))). ;;
0f70: 67 65 74 20 74 68 65 20 69 6e 66 6f 20 66 72 6f get the info fro
0f80: 6d 20 74 68 65 20 64 62 20 61 6e 64 20 70 75 74 m the db and put
0f90: 20 69 74 20 69 6e 20 74 68 65 20 63 61 63 68 65 it in the cache
0fa0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 76 61 . (if (not va
0fb0: 6c 73 29 0a 09 28 6c 65 74 20 28 28 68 74 20 28 ls)..(let ((ht (
0fc0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0fd0: 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c )).. (hash-tabl
0fe0: 65 2d 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 e-set! *env-vars
0ff0: 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d -by-run-id* run-
1000: 69 64 20 68 74 29 0a 09 20 20 28 73 65 74 21 20 id ht).. (set!
1010: 76 61 6c 73 20 68 74 29 0a 09 20 20 28 66 6f 72 vals ht).. (for
1020: 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 -each.. (lambd
1030: 61 20 28 6b 65 79 29 0a 09 20 20 20 20 20 28 68 a (key).. (h
1040: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 76 ash-table-set! v
1050: 61 6c 73 20 28 63 61 72 20 6b 65 79 29 20 28 63 als (car key) (c
1060: 61 64 72 20 6b 65 79 29 29 29 20 3b 3b 20 28 63 adr key))) ;; (c
1070: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
1080: 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 2d 76 61 6c :get-run-key-val
1090: 20 23 66 20 72 75 6e 2d 69 64 20 28 63 61 72 20 #f run-id (car
10a0: 6b 65 79 29 29 29 29 0a 09 20 20 20 6b 65 79 76 key)))).. keyv
10b0: 61 6c 73 29 29 29 0a 20 20 20 20 3b 3b 20 66 72 als))). ;; fr
10c0: 6f 6d 20 74 68 65 20 63 61 63 68 65 64 20 64 61 om the cached da
10d0: 74 61 20 73 65 74 20 74 68 65 20 76 61 72 73 0a ta set the vars.
10e0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
10f0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 76 61 for-each. va
1100: 6c 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ls. (lambda
1110: 28 6b 65 79 20 76 61 6c 29 0a 20 20 20 20 20 20 (key val).
1120: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
1130: 22 73 65 74 65 6e 76 20 22 20 6b 65 79 20 22 20 "setenv " key "
1140: 22 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 " val). (s
1150: 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 29 etenv key val)))
1160: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 67 . (if (not (g
1170: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
1180: 61 72 69 61 62 6c 65 20 22 4d 54 5f 54 41 52 47 ariable "MT_TARG
1190: 45 54 22 29 29 28 73 65 74 65 6e 76 20 22 4d 54 ET"))(setenv "MT
11a0: 5f 54 41 52 47 45 54 22 20 74 61 72 67 65 74 29 _TARGET" target)
11b0: 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e ). (alist->en
11c0: 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 v-vars (hash-tab
11d0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
11e0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d configdat* "env-
11f0: 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a override" '())).
1200: 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 ;; Lets use
1210: 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 this as an oppor
1220: 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 tunity to put MT
1230: 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 _RUNNAME in the
1240: 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 environment.
1250: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
1260: 41 4d 45 22 20 28 69 66 20 69 6e 72 75 6e 6e 61 AME" (if inrunna
1270: 6d 65 20 69 6e 72 75 6e 6e 61 6d 65 20 28 63 64 me inrunname (cd
1280: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
1290: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
12a0: 6d 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 29 29 m-id #f run-id))
12b0: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
12c0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
12d0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 0a 0a 28 *toppath*)))..(
12e0: 64 65 66 69 6e 65 20 28 73 65 74 2d 69 74 65 6d define (set-item
12f0: 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d 64 61 -env-vars itemda
1300: 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 t). (for-each (
1310: 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 20 lambda (item)..
1320: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1330: 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 63 t 2 "setenv " (c
1340: 61 72 20 69 74 65 6d 29 20 22 20 22 20 28 63 61 ar item) " " (ca
1350: 64 72 20 69 74 65 6d 29 29 0a 09 20 20 20 20 20 dr item))..
1360: 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 69 74 (setenv (car it
1370: 65 6d 29 20 28 63 61 64 72 20 69 74 65 6d 29 29 em) (cadr item))
1380: 29 0a 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 ).. itemdat))
1390: 0a 0a 3b 3b 20 45 76 65 72 79 20 74 69 6d 65 20 ..;; Every time
13a0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
13b0: 74 73 20 69 73 20 63 61 6c 6c 65 64 20 69 6e 63 ts is called inc
13c0: 72 65 6d 65 6e 74 20 74 68 65 20 64 65 6c 61 79 rement the delay
13d0: 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 57 65 20 .;;.;; NOTE: We
13e0: 72 75 6e 20 74 68 69 73 20 73 65 72 76 65 72 2d run this server-
13f0: 73 69 64 65 21 21 20 44 6f 20 6e 6f 74 20 75 73 side!! Do not us
1400: 65 20 74 68 69 73 20 67 6c 6f 62 61 6c 20 65 78 e this global ex
1410: 63 65 70 74 20 69 6e 20 74 68 65 20 72 75 6e 73 cept in the runs
1420: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
1430: 73 74 73 20 72 6f 75 74 69 6e 65 0a 3b 3b 0a 28 sts routine.;;.(
1440: 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d define *last-num
1450: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
1460: 30 29 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 0).(define *runs
1470: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
1480: 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 sts-count* 0).(d
1490: 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 69 efine (runs:shri
14a0: 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d nk-can-run-more-
14b0: 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 3b 3b 20 tests-count) ;;
14c0: 74 68 65 20 64 62 20 69 73 20 61 20 64 75 6d 6d the db is a dumm
14d0: 79 20 76 61 72 20 73 6f 20 77 65 20 63 61 6e 20 y var so we can
14e0: 75 73 65 20 63 64 62 3a 72 65 6d 6f 74 65 2d 72 use cdb:remote-r
14f0: 75 6e 0a 20 20 28 73 65 74 21 20 2a 72 75 6e 73 un. (set! *runs
1500: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
1510: 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 29 20 3b sts-count* 0)) ;
1520: 3b 20 28 2f 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 ; (/ *runs:can-r
1530: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f un-more-tests-co
1540: 75 6e 74 2a 20 32 29 29 29 0a 0a 3b 3b 20 54 65 unt* 2)))..;; Te
1550: 6d 70 6f 72 61 72 79 20 67 6c 6f 62 61 6c 73 2e mporary globals.
1560: 20 4d 6f 76 65 20 74 68 65 73 65 20 69 6e 74 6f Move these into
1570: 20 74 68 65 20 6c 6f 67 69 63 20 6f 72 20 69 6e the logic or in
1580: 74 6f 20 63 6f 6d 6d 6f 6e 0a 3b 3b 0a 28 64 65 to common.;;.(de
1590: 66 69 6e 65 20 2a 73 65 65 6e 2d 63 61 6e 74 2d fine *seen-cant-
15a0: 72 75 6e 2d 74 65 73 74 73 2a 20 28 6d 61 6b 65 run-tests* (make
15b0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
15c0: 20 75 73 65 20 74 6f 20 74 72 61 63 6b 20 74 65 use to track te
15d0: 73 74 73 20 74 68 61 74 20 77 65 20 73 75 73 70 sts that we susp
15e0: 65 63 74 20 63 61 6e 6e 6f 74 20 62 65 20 72 75 ect cannot be ru
15f0: 6e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a n.(define (runs:
1600: 69 6e 63 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 inc-cant-run-tes
1610: 74 73 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 ts testname). (
1620: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1630: 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 *seen-cant-run-t
1640: 65 73 74 73 2a 20 74 65 73 74 6e 61 6d 65 0a 09 ests* testname..
1650: 09 20 20 20 28 2b 20 28 68 61 73 68 2d 74 61 62 . (+ (hash-tab
1660: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
1670: 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 seen-cant-run-te
1680: 73 74 73 2a 20 74 65 73 74 6e 61 6d 65 20 30 29 sts* testname 0)
1690: 20 31 29 29 29 0a 28 64 65 66 69 6e 65 20 28 72 1))).(define (r
16a0: 75 6e 73 3a 63 61 6e 2d 6b 65 65 70 2d 72 75 6e uns:can-keep-run
16b0: 6e 69 6e 67 3f 20 74 65 73 74 6e 61 6d 65 20 6e ning? testname n
16c0: 29 0a 20 20 28 3c 20 28 68 61 73 68 2d 74 61 62 ). (< (hash-tab
16d0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
16e0: 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 seen-cant-run-te
16f0: 73 74 73 2a 20 74 65 73 74 6e 61 6d 65 20 30 29 sts* testname 0)
1700: 20 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 72 n))..(define *r
1710: 75 6e 73 3a 64 65 6e 6f 69 73 65 2a 20 28 6d 61 uns:denoise* (ma
1720: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1730: 3b 3b 20 6b 65 79 20 3d 3e 20 6c 61 73 74 2d 74 ;; key => last-t
1740: 69 6d 65 2d 72 61 6e 0a 0a 28 64 65 66 69 6e 65 ime-ran..(define
1750: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
1760: 6b 65 79 20 77 61 69 74 76 61 6c 29 0a 20 20 28 key waitval). (
1770: 6c 65 74 20 28 28 6c 61 73 74 74 69 6d 65 20 28 let ((lasttime (
1780: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1790: 65 66 61 75 6c 74 20 2a 72 75 6e 73 3a 64 65 6e efault *runs:den
17a0: 6f 69 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 28 oise* key 0))..(
17b0: 63 75 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e currtime (curren
17c0: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 t-seconds))).
17d0: 20 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 (if (> (- currt
17e0: 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 ime lasttime) wa
17f0: 69 74 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 itval)..(begin..
1800: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
1810: 74 21 20 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 65 t! *runs:denoise
1820: 2a 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a * key currtime).
1830: 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 . #t)..#f)))..(
1840: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e define (runs:can
1850: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 -run-more-tests
1860: 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e jobgroup max-con
1870: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 20 20 current-jobs).
1880: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
1890: 63 6f 6e 64 0a 09 09 20 20 28 28 3e 20 2a 72 75 cond... ((> *ru
18a0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
18b0: 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 32 30 29 tests-count* 20)
18c0: 20 32 29 3b 3b 20 6f 62 76 69 6f 75 73 6c 79 20 2);; obviously
18d0: 68 61 76 65 6e 27 74 20 68 61 64 20 61 6e 79 20 haven't had any
18e0: 77 6f 72 6b 20 74 6f 20 64 6f 20 66 6f 72 20 61 work to do for a
18f0: 20 77 68 69 6c 65 0a 09 09 20 20 28 65 6c 73 65 while... (else
1900: 20 30 29 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 0))). (let* ((
1910: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 num-running
1920: 20 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d (cdb:rem
1930: 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 63 ote-run db:get-c
1940: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
1950: 6e 67 20 23 66 29 29 0a 09 20 28 6e 75 6d 2d 72 ng #f)).. (num-r
1960: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
1970: 75 70 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 up (cdb:remote-r
1980: 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d un db:get-count-
1990: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e tests-running-in
19a0: 2d 6a 6f 62 67 72 6f 75 70 20 23 66 20 6a 6f 62 -jobgroup #f job
19b0: 67 72 6f 75 70 29 29 0a 09 20 28 6a 6f 62 2d 67 group)).. (job-g
19c0: 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 roup-limit
19d0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
19e0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
19f0: 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f obgroups" jobgro
1a00: 75 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e up))). (if (>
1a10: 20 28 2b 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 (+ num-running
1a20: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1a30: 6f 62 67 72 6f 75 70 29 20 30 29 0a 09 28 73 65 obgroup) 0)..(se
1a40: 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e t! *runs:can-run
1a50: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
1a60: 74 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d t* (+ *runs:can-
1a70: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1a80: 6f 75 6e 74 2a 20 31 29 29 29 0a 20 20 20 20 28 ount* 1))). (
1a90: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 if (not (eq? *la
1aa0: 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 st-num-running-t
1ab0: 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e ests* num-runnin
1ac0: 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 g))..(begin.. (
1ad0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 6d debug:print 2 "m
1ae0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1af0: 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 bs: " max-concur
1b00: 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d rent-jobs ", num
1b10: 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d -running: " num-
1b20: 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 73 65 74 running).. (set
1b30: 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e ! *last-num-runn
1b40: 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 ing-tests* num-r
1b50: 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 20 28 69 unning))). (i
1b60: 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 f (not (eq? 0 *g
1b70: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
1b80: 29 29 0a 09 28 6c 69 73 74 20 23 66 20 6e 75 6d ))..(list #f num
1b90: 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e -running num-run
1ba0: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
1bb0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1bc0: 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c jobs job-group-l
1bd0: 69 6d 69 74 29 0a 09 28 6c 65 74 20 28 28 63 61 imit)..(let ((ca
1be0: 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 n-not-run-more (
1bf0: 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 69 66 20 cond..... ;; if
1c00: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1c10: 6f 62 73 20 69 73 20 73 65 74 20 61 6e 64 20 74 obs is set and t
1c20: 68 65 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e he number runnin
1c30: 67 20 69 73 20 67 72 65 61 74 65 72 20 0a 09 09 g is greater ...
1c40: 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 20 74 68 .. ;; than it th
1c50: 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f an cannot run mo
1c60: 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 28 28 61 re jobs..... ((a
1c70: 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e nd max-concurren
1c80: 74 2d 6a 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d 72 t-jobs (>= num-r
1c90: 75 6e 6e 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 75 unning max-concu
1ca0: 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 09 rrent-jobs))....
1cb0: 09 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 . (if (runs:low
1cc0: 6e 6f 69 73 65 20 22 6d 63 6a 20 6d 73 67 22 20 noise "mcj msg"
1cd0: 36 30 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 60)..... (d
1ce0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
1cf0: 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 RNING: Max runni
1d00: 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 64 ng jobs exceeded
1d10: 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 , current number
1d20: 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d running: " num-
1d30: 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 09 20 running .......
1d40: 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 ", max_concurr
1d50: 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d ent_jobs: " max-
1d60: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 concurrent-jobs)
1d70: 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 )..... #t).....
1d80: 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 6f 75 70 ;; if job-group
1d90: 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 20 61 6e -limit is set an
1da0: 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 d number of jobs
1db0: 20 69 6e 20 74 68 65 20 67 72 6f 75 70 20 69 73 in the group is
1dc0: 20 67 72 65 61 74 65 72 0a 09 09 09 09 20 3b 3b greater..... ;;
1dd0: 20 74 68 61 6e 20 74 68 65 20 6c 69 6d 69 74 20 than the limit
1de0: 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 then cannot run
1df0: 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 74 68 69 more jobs of thi
1e00: 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 28 61 6e s kind..... ((an
1e10: 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 d job-group-limi
1e20: 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 3e 3d t..... (>=
1e30: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d num-running-in-
1e40: 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d 67 72 6f jobgroup job-gro
1e50: 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 up-limit)).....
1e60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
1e70: 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 72 "WARNING: number
1e80: 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 6d 2d 72 of jobs " num-r
1e90: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
1ea0: 75 70 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 up ......
1eb0: 22 20 69 6e 20 22 20 6a 6f 62 67 72 6f 75 70 20 " in " jobgroup
1ec0: 22 20 65 78 63 65 65 64 65 64 2c 20 77 69 6c 6c " exceeded, will
1ed0: 20 6e 6f 74 20 72 75 6e 20 22 20 28 74 65 73 74 not run " (test
1ee0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
1ef0: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
1f00: 63 6f 72 64 29 29 0a 09 09 09 09 20 20 23 74 29 cord))..... #t)
1f10: 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 29 29 ..... (else #f))
1f20: 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f 74 )).. (list (not
1f30: 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 can-not-run-mor
1f40: 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e e) num-running n
1f50: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
1f60: 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 bgroup max-concu
1f70: 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 rrent-jobs job-g
1f80: 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 0a roup-limit))))).
1f90: 0a 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 73 3a .;; test-names:
1fa0: 20 43 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 Comma separated
1fb0: 20 70 61 74 74 65 72 6e 73 20 73 61 6d 65 20 61 patterns same a
1fc0: 73 20 74 65 73 74 2d 70 61 74 74 73 20 62 75 74 s test-patts but
1fd0: 20 75 73 65 64 20 69 6e 20 73 65 6c 65 63 74 69 used in selecti
1fe0: 6f 6e 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 on .;;
1ff0: 20 20 20 20 6f 66 20 74 65 73 74 73 20 74 6f 20 of tests to
2000: 72 75 6e 2e 20 54 68 65 20 69 74 65 6d 20 70 6f run. The item po
2010: 72 74 69 6f 6e 73 20 61 72 65 20 6e 6f 74 20 72 rtions are not r
2020: 65 73 70 65 63 74 65 64 2e 0a 3b 3b 20 20 20 20 espected..;;
2030: 20 20 20 20 20 20 20 20 20 20 46 49 58 4d 45 3a FIXME:
2040: 20 65 72 72 6f 72 20 6f 75 74 20 69 66 20 2f 70 error out if /p
2050: 61 74 74 20 73 70 65 63 69 66 69 65 64 0a 3b 3b att specified.;;
2060: 20 20 20 20 20 20 20 20 20 20 20 20 0a 28 64 65 .(de
2070: 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 fine (runs:run-t
2080: 65 73 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e ests target runn
2090: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 ame test-patts u
20a0: 73 65 72 20 66 6c 61 67 73 29 20 3b 3b 20 74 65 ser flags) ;; te
20b0: 73 74 2d 6e 61 6d 65 73 0a 20 20 28 63 6f 6d 6d st-names. (comm
20c0: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
20d0: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
20e0: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 6b ches. (let* ((k
20f0: 65 79 73 20 20 20 20 20 20 20 20 20 20 20 20 20 eys
2100: 20 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 (keys:config-g
2110: 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 et-fields *confi
2120: 67 64 61 74 2a 29 29 0a 09 20 28 6b 65 79 76 61 gdat*)).. (keyva
2130: 6c 73 20 20 20 20 20 20 20 20 20 20 20 20 28 6b ls (k
2140: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
2150: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
2160: 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 .. (run-id
2170: 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f (cdb:remo
2180: 74 65 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 74 te-run db:regist
2190: 65 72 2d 72 75 6e 20 23 66 20 6b 65 79 76 61 6c er-run #f keyval
21a0: 73 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 s runname "new"
21b0: 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b 3b "n/a" user)) ;;
21c0: 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 test-name)))..
21d0: 20 28 64 65 66 65 72 72 65 64 20 20 20 20 20 20 (deferred
21e0: 20 20 20 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 '()) ;; dela
21f0: 79 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 y running these
2200: 73 69 6e 63 65 20 74 68 65 79 20 68 61 76 65 20 since they have
2210: 61 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a a waiton clause.
2220: 09 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 . (runconfigf
2230: 20 20 20 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f (conc *to
2240: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
2250: 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 igs.config"))..
2260: 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 (required-tests
2270: 20 20 20 27 28 29 29 0a 09 20 28 74 65 73 74 2d '()).. (test-
2280: 72 65 63 6f 72 64 73 20 20 20 20 20 20 20 28 6d records (m
2290: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
22a0: 0a 09 20 28 61 6c 6c 2d 74 65 73 74 73 2d 72 65 .. (all-tests-re
22b0: 67 69 73 74 72 79 20 28 74 65 73 74 73 3a 67 65 gistry (tests:ge
22c0: 74 2d 61 6c 6c 29 29 20 3b 3b 20 28 74 65 73 74 t-all)) ;; (test
22d0: 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 s:get-valid-test
22e0: 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
22f0: 6c 65 29 20 74 65 73 74 2d 73 65 61 72 63 68 2d le) test-search-
2300: 70 61 74 68 29 29 20 3b 3b 20 61 6c 6c 20 76 61 path)) ;; all va
2310: 6c 69 64 20 74 65 73 74 73 20 74 6f 20 63 68 65 lid tests to che
2320: 63 6b 20 77 61 69 74 6f 6e 20 6e 61 6d 65 73 0a ck waiton names.
2330: 09 20 28 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 . (all-test-name
2340: 73 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c s (hash-tabl
2350: 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 65 73 74 73 e-keys all-tests
2360: 2d 72 65 67 69 73 74 72 79 29 29 0a 09 20 28 74 -registry)).. (t
2370: 65 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 20 20 est-names
2380: 20 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d (tests:filter-
2390: 74 65 73 74 2d 6e 61 6d 65 73 20 61 6c 6c 2d 74 test-names all-t
23a0: 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 est-names test-p
23b0: 61 74 74 73 29 29 29 0a 20 20 20 20 28 73 65 74 atts))). (set
23c0: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
23d0: 72 73 20 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 rs run-id inkeys
23e0: 3a 20 6b 65 79 73 29 20 3b 3b 20 74 68 65 73 65 : keys) ;; these
23f0: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
2400: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
2410: 70 72 6f 63 65 73 73 0a 20 20 20 20 28 69 66 20 process. (if
2420: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 (file-exists? ru
2430: 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 nconfigf)..(setu
2440: 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 72 p-env-defaults r
2450: 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 unconfigf run-id
2460: 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 *already-seen-r
2470: 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 6b unconfig-info* k
2480: 65 79 76 61 6c 73 20 22 70 72 65 2d 6c 61 75 6e eyvals "pre-laun
2490: 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 0a 09 28 ch-env-vars")..(
24a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
24b0: 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e ARNING: You do n
24c0: 6f 74 20 68 61 76 65 20 61 20 72 75 6e 20 63 6f ot have a run co
24d0: 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 72 75 6e nfig file: " run
24e0: 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 20 0a 20 configf)). .
24f0: 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c ;; look up al
2500: 6c 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e 67 l tests matching
2510: 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 61 72 the comma separ
2520: 61 74 65 64 20 6c 69 73 74 20 6f 66 20 67 6c 6f ated list of glo
2530: 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 65 73 bs in. ;; tes
2540: 74 2d 70 61 74 74 73 20 28 75 73 69 6e 67 20 25 t-patts (using %
2550: 20 61 73 20 77 69 6c 64 63 61 72 64 29 0a 0a 20 as wildcard)..
2560: 20 20 20 3b 3b 20 28 73 65 74 21 20 74 65 73 74 ;; (set! test
2570: 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 2d 64 -names (delete-d
2580: 75 70 6c 69 63 61 74 65 73 20 28 74 65 73 74 73 uplicates (tests
2590: 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 :get-valid-tests
25a0: 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 73 74 2d *toppath* test-
25b0: 70 61 74 74 73 29 29 29 0a 20 20 20 20 28 64 65 patts))). (de
25c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
25d0: 20 22 74 65 73 74 20 6e 61 6d 65 73 20 22 20 74 "test names " t
25e0: 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 20 20 est-names)..
25f0: 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 ;; on the first
2600: 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 pass or call to
2610: 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 46 41 run-tests set FA
2620: 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 ILS to NOT_START
2630: 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 ED if. ;; -ke
2640: 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 63 69 epgoing is speci
2650: 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 65 71 fied. (if (eq
2660: 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 ? *passnum* 0)..
2670: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 (begin.. ;; hav
2680: 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 e to delete test
2690: 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e records where N
26a0: 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 OT_STARTED since
26b0: 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 they can cause
26c0: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 -keepgoing to ..
26d0: 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 ;; get stuck d
26e0: 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 ue to becoming i
26f0: 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d naccessible from
2700: 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 a failed test.
2710: 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 I.e. if test B d
2720: 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e epends .. ;; on
2730: 20 74 65 73 74 20 41 20 62 75 74 20 74 65 73 74 test A but test
2740: 20 42 20 72 65 61 63 68 65 64 20 74 68 65 20 70 B reached the p
2750: 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 oint on being re
2760: 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f gistered as NOT_
2770: 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 STARTED and test
2780: 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 .. ;; A failed
2790: 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 for some reason
27a0: 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 then on re-run u
27b0: 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 sing -keepgoing
27c0: 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 the run can neve
27d0: 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 r complete... (
27e0: 63 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 cdb:delete-tests
27f0: 2d 69 6e 2d 73 74 61 74 65 20 2a 72 75 6e 72 65 -in-state *runre
2800: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 22 4e 4f mote* run-id "NO
2810: 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 20 28 T_STARTED").. (
2820: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
2830: 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 b:set-tests-stat
2840: 65 2d 73 74 61 74 75 73 20 23 66 20 72 75 6e 2d e-status #f run-
2850: 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 23 66 id test-names #f
2860: 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 54 41 "FAIL" "NOT_STA
2870: 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 29 0a RTED" "FAIL"))).
2880: 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 . ;; now add
2890: 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 66 non-directly ref
28a0: 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 65 6e erenced dependen
28b0: 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 74 6f cies (i.e. waito
28c0: 6e 29 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d n). ;;=======
28d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
2910: 20 20 20 20 3b 3b 20 72 65 66 61 63 74 6f 72 69 ;; refactori
2920: 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 69 6e ng this block in
2930: 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 75 6c to tests:get-ful
2940: 6c 2d 64 61 74 61 0a 20 20 20 20 3b 3b 0a 20 20 l-data. ;;.
2950: 20 20 3b 3b 20 57 68 61 74 20 68 61 70 70 65 6e ;; What happen
2960: 64 65 64 2c 20 74 68 69 73 20 63 6f 64 65 20 69 ded, this code i
2970: 73 20 6e 6f 77 20 64 75 70 6c 69 63 61 74 65 64 s now duplicated
2980: 20 69 6e 20 74 65 73 74 73 21 3f 0a 20 20 20 20 in tests!?.
2990: 3b 3b 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ;;. ;;=======
29a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
29e0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
29f0: 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ll? test-names))
2a00: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
2a10: 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 d (car test-name
2a20: 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 s))... (tal (c
2a30: 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 dr test-names)))
2a40: 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 ;; 'ret
2a50: 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 urn-procs tells
2a60: 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 the config reade
2a70: 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e r to prep runnin
2a80: 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 g system but ret
2a90: 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 63 urn a proc.. (c
2aa0: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
2ab0: 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b 20 50 4c *toppath*) ;; PL
2ac0: 45 41 53 45 20 4f 50 54 49 4d 49 5a 45 20 4d 45 EASE OPTIMIZE ME
2ad0: 21 21 21 20 49 20 74 68 69 6e 6b 20 74 68 69 73 !!! I think this
2ae0: 20 73 68 6f 75 6c 64 20 62 65 20 61 20 6e 6f 2d should be a no-
2af0: 6f 70 20 62 75 74 20 74 68 65 72 65 20 61 72 65 op but there are
2b00: 20 73 65 76 65 72 61 6c 20 70 6c 61 63 65 73 20 several places
2b10: 77 68 65 72 65 20 63 68 61 6e 67 65 2d 64 69 72 where change-dir
2b20: 65 63 74 6f 72 69 65 73 20 63 6f 75 6c 64 20 62 ectories could b
2b30: 65 20 68 61 70 70 65 6e 69 6e 67 2e 0a 09 20 20 e happening...
2b40: 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
2b50: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
2b60: 6f 6e 66 69 67 20 68 65 64 20 61 6c 6c 2d 74 65 onfig hed all-te
2b70: 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 sts-registry 're
2b80: 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 20 turn-procs))...
2b90: 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 (waitons (let ((
2ba0: 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 instr (if config
2bb0: 20 0a 09 09 09 09 09 20 20 20 28 63 6f 6e 66 69 ...... (confi
2bc0: 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
2bd0: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
2be0: 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 20 waiton")......
2bf0: 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f (begin ;; No co
2c00: 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 nfig means this
2c10: 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e is a non-existan
2c20: 74 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 t test......
2c30: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2c40: 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 "ERROR: non-exis
2c50: 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 tent required te
2c60: 73 74 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 st \"" hed "\"")
2c70: 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 69 74 ...... (exit
2c80: 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 20 28 1))))).... (
2c90: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2ca0: 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 8 "waitons stri
2cb0: 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 0a 09 ng is " instr)..
2cc0: 09 09 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 .. (let ((new
2cd0: 77 61 69 74 6f 6e 73 0a 09 09 09 09 20 20 20 28 waitons..... (
2ce0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f string-split (co
2cf0: 6e 64 0a 09 09 09 09 09 09 20 20 28 28 70 72 6f nd....... ((pro
2d00: 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 cedure? instr)..
2d10: 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 72 ..... (let ((r
2d20: 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 es (instr)))....
2d30: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
2d40: 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 rint-info 8 "wai
2d50: 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 ton procedure re
2d60: 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
2d70: 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
2d80: 20 22 20 68 65 64 29 0a 09 09 09 09 09 09 20 20 " hed).......
2d90: 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 09 20 res)).......
2da0: 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 ((string? instr
2db0: 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 ) instr)....
2dc0: 09 09 09 20 20 28 65 6c 73 65 20 0a 09 09 09 09 ... (else .....
2dd0: 09 09 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 .. ;; NOTE: Th
2de0: 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
2df0: 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
2e00: 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 waitons! ;; (deb
2e10: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
2e20: 52 3a 20 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e R: something wen
2e30: 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 t wrong in proce
2e40: 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f ssing waitons fo
2e50: 72 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 r test " hed)...
2e60: 09 09 09 09 20 20 20 22 22 29 29 29 29 29 0a 09 .... "")))))..
2e70: 09 09 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 .. (filter
2e80: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
2e90: 09 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 .(if (hash-table
2ea0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c -ref/default all
2eb0: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
2ec0: 78 20 23 66 29 0a 09 09 09 09 09 20 20 20 20 23 x #f)...... #
2ed0: 74 0a 09 09 09 09 09 20 20 20 20 28 62 65 67 69 t...... (begi
2ee0: 6e 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 65 n...... (de
2ef0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
2f00: 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 OR: test " hed "
2f10: 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 has unrecognise
2f20: 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d d waiton testnam
2f30: 65 20 22 20 78 29 0a 09 09 09 09 09 20 20 20 20 e " x)......
2f40: 20 20 23 66 29 29 29 0a 09 09 09 09 20 20 20 20 #f))).....
2f50: 20 20 6e 65 77 77 61 69 74 6f 6e 73 29 29 29 29 newwaitons))))
2f60: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
2f70: 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 int-info 8 "wait
2f80: 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a ons: " waitons).
2f90: 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f . ;; check fo
2fa0: 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 r hed in waitons
2fb0: 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 => this would b
2fc0: 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f e circular, remo
2fd0: 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 ve it and issue
2fe0: 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 an.. ;; error
2ff0: 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 .. (if (membe
3000: 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 r hed waitons)..
3010: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
3020: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
3030: 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 R: test " hed "
3040: 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c has listed itsel
3050: 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 f as a waiton, p
3060: 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 lease correct th
3070: 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 is!")... (set!
3080: 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 waitons (filter
3090: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
30a0: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
30b0: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 waitons))))..
30c0: 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 6d .. ;; (item
30d0: 73 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 s (items:get-i
30e0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
30f0: 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 20 config)))..
3100: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
3110: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3120: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
3130: 64 20 23 66 29 29 0a 09 09 28 68 61 73 68 2d 74 d #f))...(hash-t
3140: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
3150: 65 63 6f 72 64 73 0a 09 09 09 09 20 68 65 64 20 ecords..... hed
3160: 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 (vector hed
3170: 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 20 20 63 ;; 0...... c
3180: 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 onfig ;; 1.....
3190: 09 20 20 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b . waitons ;;
31a0: 20 32 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 2...... (co
31b0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
31c0: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
31d0: 22 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 " "priority")
31e0: 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a ;; priority 3.
31f0: 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 ..... (let (
3200: 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 (items (has
3210: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3220: 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d ult config "item
3230: 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 s" #f)) ;; items
3240: 20 34 0a 09 09 09 09 09 09 20 20 20 28 69 74 65 4....... (ite
3250: 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 mstable (hash-ta
3260: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
3270: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 config "itemstab
3280: 6c 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 le" #f))) ......
3290: 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 ;; if eit
32a0: 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 her items or ite
32b0: 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 ms table is a pr
32c0: 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 oc return it so
32d0: 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 test running....
32e0: 09 09 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 .. ;; proc
32f0: 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 ess can know to
3300: 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 call items:get-i
3310: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
3320: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
3330: 69 66 20 65 69 74 68 65 72 20 69 73 20 61 20 6c if either is a l
3340: 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 ist and none is
3350: 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 a proc go ahead
3360: 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 and call get-ite
3370: 6d 73 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ms...... ;
3380: 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 ; otherwise retu
3390: 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 rn #f - this is
33a0: 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 not an iterated
33b0: 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 20 20 test......
33c0: 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 (cond.......((p
33d0: 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 rocedure? items)
33e0: 20 20 20 20 20 20 0a 09 09 09 09 09 09 20 28 64 ....... (d
33f0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3400: 34 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 4 "items is a pr
3410: 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 ocedure, will ca
3420: 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 lc later")......
3430: 09 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 . items)
3440: 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 ;; calc late
3450: 72 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 r.......((proced
3460: 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ure? itemstable)
3470: 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 ....... (debug:p
3480: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 rint-info 4 "ite
3490: 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f mstable is a pro
34a0: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
34b0: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
34c0: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 itemstable)
34d0: 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 ;; calc later
34e0: 0a 09 09 09 09 09 09 28 28 66 69 6c 74 65 72 20 .......((filter
34f0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
3500: 09 09 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c ... (let ((val
3510: 20 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 (car x)))......
3520: 09 09 20 20 20 20 20 28 69 66 20 28 70 72 6f 63 .. (if (proc
3530: 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 edure? val) val
3540: 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 28 61 #f)))........ (a
3550: 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f ppend (if (list?
3560: 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 items) items '(
3570: 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 ))......... (if
3580: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
3590: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
35a0: 29 29 29 29 0a 09 09 09 09 09 09 20 27 68 61 76 ))))....... 'hav
35b0: 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 e-procedure)....
35c0: 09 09 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 ...((or (list? i
35d0: 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d tems)(list? item
35e0: 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 stable)) ;; calc
35f0: 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 65 62 now....... (deb
3600: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
3610: 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 "items and items
3620: 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
3630: 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
3640: 09 09 09 09 09 20 20 20 22 20 20 20 20 69 74 65 ..... " ite
3650: 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 ms: " items " it
3660: 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d emstable: " item
3670: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
3680: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
3690: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
36a0: 69 67 29 29 0a 09 09 09 09 09 09 28 65 6c 73 65 ig)).......(else
36b0: 20 23 66 29 29 29 20 20 20 20 20 20 20 20 20 20 #f)))
36c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36d0: 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 ;; not iterated
36e0: 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 ...... #f
36f0: 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 ;; itemsdat 5
3700: 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 ...... #f
3710: 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 ;; spare - us
3720: 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 ed for item-path
3730: 0a 09 09 09 09 09 20 20 20 20 20 29 29 29 0a 09 ...... )))..
3740: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 (for-each ..
3750: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 (lambda (wa
3760: 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 69 iton).. (i
3770: 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e f (and waiton (n
3780: 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f ot (member waito
3790: 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a n test-names))).
37a0: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 .. (begin...
37b0: 20 20 20 28 73 65 74 21 20 72 65 71 75 69 72 65 (set! require
37c0: 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 d-tests (cons wa
37d0: 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 iton required-te
37e0: 73 74 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 sts))... (se
37f0: 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 t! test-names (c
3800: 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ons waiton test-
3810: 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 names))))) ;; wa
3820: 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 s an append, now
3830: 20 61 20 63 6f 6e 73 0a 09 20 20 20 20 20 77 61 a cons.. wa
3840: 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 itons).. (let
3850: 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c ((remtests (del
3860: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
3870: 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 append waitons t
3880: 61 6c 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 al)))).. (i
3890: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 f (not (null? re
38a0: 6d 74 65 73 74 73 29 29 0a 09 09 20 20 28 6c 6f mtests))... (lo
38b0: 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 op (car remtests
38c0: 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 )(cdr remtests))
38d0: 29 29 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 ))))).. (if (
38e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 not (null? requi
38f0: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 28 64 65 red-tests))..(de
3900: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
3910: 20 22 41 64 64 69 6e 67 20 22 20 72 65 71 75 69 "Adding " requi
3920: 72 65 64 2d 74 65 73 74 73 20 22 20 74 6f 20 74 red-tests " to t
3930: 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 29 0a he run queue")).
3940: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 ;; NOTE: the
3950: 73 65 20 61 72 65 20 61 6c 6c 20 70 61 72 65 6e se are all paren
3960: 74 20 74 65 73 74 73 2c 20 69 74 65 6d 73 20 61 t tests, items a
3970: 72 65 20 6e 6f 74 20 65 78 70 61 6e 64 65 64 20 re not expanded
3980: 79 65 74 2e 0a 20 20 20 20 28 64 65 62 75 67 3a yet.. (debug:
3990: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 print-info 4 "te
39a0: 73 74 2d 72 65 63 6f 72 64 73 3d 22 20 28 68 61 st-records=" (ha
39b0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
39c0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 test-records)).
39d0: 20 20 20 28 6c 65 74 20 28 28 72 65 67 6c 65 6e (let ((reglen
39e0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
39f0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
3a00: 74 75 70 22 20 22 72 75 6e 71 75 65 75 65 22 29 tup" "runqueue")
3a10: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 )). (if (>
3a20: 28 6c 65 6e 67 74 68 20 28 68 61 73 68 2d 74 61 (length (hash-ta
3a30: 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 ble-keys test-re
3a40: 63 6f 72 64 73 29 29 20 30 29 0a 09 20 20 28 72 cords)) 0).. (r
3a50: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu
3a60: 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 eue run-id runna
3a70: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 me test-records
3a80: 6b 65 79 76 61 6c 73 20 66 6c 61 67 73 20 74 65 keyvals flags te
3a90: 73 74 2d 70 61 74 74 73 20 72 65 71 75 69 72 65 st-patts require
3aa0: 64 2d 74 65 73 74 73 20 28 61 6e 79 2d 3e 6e 75 d-tests (any->nu
3ab0: 6d 62 65 72 20 72 65 67 6c 65 6e 29 20 61 6c 6c mber reglen) all
3ac0: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 -tests-registry)
3ad0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
3ae0: 2d 69 6e 66 6f 20 30 20 22 4e 6f 20 74 65 73 74 -info 0 "No test
3af0: 73 20 74 6f 20 72 75 6e 22 29 29 29 0a 20 20 20 s to run"))).
3b00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3b10: 66 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 62 fo 4 "All done b
3b20: 79 20 68 65 72 65 22 29 29 29 0a 0a 0a 3b 3b 20 y here")))...;;
3b30: 6c 6f 6f 70 20 6c 6f 67 69 63 2e 20 54 68 65 73 loop logic. Thes
3b40: 65 20 61 72 65 20 75 73 65 64 20 69 6e 20 72 75 e are used in ru
3b50: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 ns:run-tests-que
3b60: 75 65 20 74 6f 20 6d 61 6b 65 20 69 74 20 61 20 ue to make it a
3b70: 62 69 74 20 6d 6f 72 65 20 72 65 61 64 61 62 6c bit more readabl
3b80: 65 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 72 65 67 20 e..;;.;; If reg
3b90: 6e 6f 74 20 66 75 6c 6c 20 61 6e 64 20 68 61 76 not full and hav
3ba0: 65 20 69 74 65 6d 73 20 69 6e 20 74 61 6c 20 74 e items in tal t
3bb0: 68 65 6e 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 hen loop with (c
3bc0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
3bd0: 20 72 65 67 20 72 65 72 75 6e 73 0a 3b 3b 20 49 reg reruns.;; I
3be0: 66 20 72 65 67 20 69 73 20 66 75 6c 6c 20 28 69 f reg is full (i
3bf0: 2e 65 2e 20 6c 65 6e 67 74 68 20 3e 3d 20 6e 0a .e. length >= n.
3c00: 3b 3b 20 20 20 6c 6f 6f 70 20 77 69 74 68 20 28 ;; loop with (
3c10: 63 61 72 20 72 65 67 29 20 74 61 6c 20 28 63 64 car reg) tal (cd
3c20: 72 20 72 65 67 29 20 72 65 72 75 6e 73 0a 3b 3b r reg) reruns.;;
3c30: 20 49 66 20 74 61 6c 20 69 73 20 65 6d 70 74 79 If tal is empty
3c40: 0a 3b 3b 20 20 20 62 75 74 20 68 61 76 65 20 69 .;; but have i
3c50: 74 65 6d 73 20 69 6e 20 72 65 67 3b 20 6c 6f 6f tems in reg; loo
3c60: 70 20 77 69 74 68 20 28 63 61 72 20 72 65 67 29 p with (car reg)
3c70: 28 63 64 72 20 72 65 67 29 20 27 28 29 20 72 65 (cdr reg) '() re
3c80: 72 75 6e 73 0a 3b 3b 20 20 20 49 66 20 72 65 67 runs.;; If reg
3c90: 20 69 73 20 65 6d 70 74 79 20 3d 3e 20 61 6c 6c is empty => all
3ca0: 20 64 6f 6e 65 0a 0a 28 64 65 66 69 6e 65 20 28 done..(define (
3cb0: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
3cc0: 68 65 64 20 74 61 6c 20 72 65 67 20 6e 20 72 65 hed tal reg n re
3cd0: 67 66 75 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 gfull). (if reg
3ce0: 66 75 6c 6c 0a 20 20 20 20 20 20 28 63 61 72 20 full. (car
3cf0: 72 65 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 reg). (if (
3d00: 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 74 61 null? tal) ;; ta
3d10: 6c 20 69 73 20 75 73 65 64 20 75 70 2c 20 70 6f l is used up, po
3d20: 70 20 66 72 6f 6d 20 72 65 67 0a 09 20 20 28 63 p from reg.. (c
3d30: 61 72 20 72 65 67 29 0a 09 20 20 28 63 61 72 20 ar reg).. (car
3d40: 74 61 6c 29 29 29 29 0a 0a 3b 3b 20 20 20 28 63 tal))))..;; (c
3d50: 6f 6e 64 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 ond.;; ((and
3d60: 72 65 67 66 75 6c 6c 20 28 6e 75 6c 6c 3f 20 72 regfull (null? r
3d70: 65 67 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 eg)(not (null? t
3d80: 61 6c 29 29 29 20 20 20 20 20 20 28 63 61 72 20 al))) (car
3d90: 74 61 6c 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e tal)).;; ((an
3da0: 64 20 72 65 67 66 75 6c 6c 20 28 6e 6f 74 20 28 d regfull (not (
3db0: 6e 75 6c 6c 3f 20 72 65 67 29 29 29 20 20 20 20 null? reg)))
3dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
3dd0: 72 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 r reg)).;; ((
3de0: 61 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c and (not regfull
3df0: 29 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 6f 74 )(null? tal)(not
3e00: 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 20 28 (null? reg))) (
3e10: 63 61 72 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 car reg)).;;
3e20: 28 28 61 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 ((and (not regfu
3e30: 6c 6c 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 ll)(not (null? t
3e40: 61 6c 29 29 29 20 20 20 20 20 20 20 20 20 20 20 al)))
3e50: 20 28 63 61 72 20 74 61 6c 29 29 0a 3b 3b 20 20 (car tal)).;;
3e60: 20 20 28 65 6c 73 65 0a 3b 3b 20 20 20 20 20 28 (else.;; (
3e70: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
3e80: 52 52 4f 52 3a 20 72 75 6e 73 3a 71 75 65 75 65 RROR: runs:queue
3e90: 2d 6e 65 78 74 2d 68 65 64 2c 20 74 61 6c 3d 22 -next-hed, tal="
3ea0: 20 74 61 6c 20 22 2c 20 72 65 67 3d 22 20 72 65 tal ", reg=" re
3eb0: 67 20 22 2c 20 6e 3d 22 20 6e 20 22 2c 20 72 65 g ", n=" n ", re
3ec0: 67 66 75 6c 6c 3d 22 20 72 65 67 66 75 6c 6c 29 gfull=" regfull)
3ed0: 0a 3b 3b 20 20 20 20 20 23 66 29 29 29 0a 0a 28 .;; #f)))..(
3ee0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 define (runs:que
3ef0: 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 ue-next-tal tal
3f00: 72 65 67 20 6e 20 72 65 67 66 75 6c 6c 29 0a 20 reg n regfull).
3f10: 20 28 69 66 20 72 65 67 66 75 6c 6c 0a 20 20 20 (if regfull.
3f20: 20 20 20 74 61 6c 0a 20 20 20 20 20 20 28 69 66 tal. (if
3f30: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 (null? tal) ;;
3f40: 6d 75 73 74 20 74 72 61 6e 73 66 65 72 20 66 72 must transfer fr
3f50: 6f 6d 20 72 65 67 0a 09 20 20 28 63 64 72 20 72 om reg.. (cdr r
3f60: 65 67 29 0a 09 20 20 28 63 64 72 20 74 61 6c 29 eg).. (cdr tal)
3f70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
3f80: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 ns:queue-next-re
3f90: 67 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 g tal reg n regf
3fa0: 75 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 ull). (if regfu
3fb0: 6c 6c 0a 20 20 20 20 20 20 28 63 64 72 20 72 65 ll. (cdr re
3fc0: 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 g). (if (nu
3fd0: 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 69 66 20 74 ll? tal) ;; if t
3fe0: 61 6c 20 69 73 20 6e 75 6c 6c 20 61 6e 64 20 72 al is null and r
3ff0: 65 67 20 6e 6f 74 20 66 75 6c 6c 20 74 68 65 6e eg not full then
4000: 20 27 28 29 20 61 73 20 72 65 67 20 63 6f 6e 74 '() as reg cont
4010: 65 6e 74 73 20 6d 6f 76 65 64 20 74 6f 20 74 61 ents moved to ta
4020: 6c 0a 09 20 20 27 28 29 0a 09 20 20 72 65 67 29 l.. '().. reg)
4030: 29 29 0a 0a 28 64 65 66 69 6e 65 20 72 75 6e 73 ))..(define runs
4040: 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e :nothing-left-in
4050: 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 30 29 0a -queue-count 0).
4060: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 65 .(define (runs:e
4070: 78 70 61 6e 64 2d 69 74 65 6d 73 20 68 65 64 20 xpand-items hed
4080: 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 tal reg reruns r
4090: 65 67 66 75 6c 6c 20 6e 65 77 74 61 6c 20 6a 6f egfull newtal jo
40a0: 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 bgroup max-concu
40b0: 72 72 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 rrent-jobs run-i
40c0: 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 d waitons item-p
40d0: 61 74 68 20 74 65 73 74 6d 6f 64 65 20 74 65 73 ath testmode tes
40e0: 74 2d 72 65 63 6f 72 64 20 63 61 6e 2d 72 75 6e t-record can-run
40f0: 2d 6d 6f 72 65 20 69 74 65 6d 73 20 72 75 6e 6e -more items runn
4100: 61 6d 65 20 74 63 6f 6e 66 69 67 20 72 65 67 6c ame tconfig regl
4110: 65 6e 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 en test-registry
4120: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 6f 70 ). (let* ((loop
4130: 2d 6c 69 73 74 20 20 20 20 20 20 20 28 6c 69 73 -list (lis
4140: 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t hed tal reg re
4150: 72 75 6e 73 29 29 0a 09 20 28 70 72 65 72 65 71 runs)).. (prereq
4160: 73 2d 6e 6f 74 2d 6d 65 74 20 28 6d 74 3a 67 65 s-not-met (mt:ge
4170: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
4180: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
4190: 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a item-path mode:
41a0: 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 20 28 66 testmode)).. (f
41b0: 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 28 ails (
41c0: 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 runs:calc-fails
41d0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
41e0: 29 0a 09 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ).. (non-complet
41f0: 65 64 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d ed (runs:calc-
4200: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
4210: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 ereqs-not-met)))
4220: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4230: 74 2d 69 6e 66 6f 20 34 20 22 53 54 41 52 54 20 t-info 4 "START
4240: 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 20 23 32 OF INNER COND #2
4250: 20 22 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 63 "... "\n c
4260: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 20 20 an-run-more:
4270: 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 " can-run-more..
4280: 09 20 20 20 20 20 20 22 5c 6e 20 74 65 73 74 6e . "\n testn
4290: 61 6d 65 3a 20 20 20 20 20 20 20 20 22 20 68 65 ame: " he
42a0: 64 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 70 72 d... "\n pr
42b0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 ereqs-not-met: "
42c0: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
42d0: 72 69 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 ring prereqs-not
42e0: 2d 6d 65 74 29 0a 09 09 20 20 20 20 20 20 22 5c -met)... "\
42f0: 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 3a n non-completed:
4300: 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 " (runs:prett
4310: 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f 6d y-string non-com
4320: 70 6c 65 74 65 64 29 20 0a 09 09 20 20 20 20 20 pleted) ...
4330: 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 "\n fails:
4340: 20 20 20 20 20 20 22 20 28 72 75 6e 73 3a 70 72 " (runs:pr
4350: 65 74 74 79 2d 73 74 72 69 6e 67 20 66 61 69 6c etty-string fail
4360: 73 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 74 s)... "\n t
4370: 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 20 20 estmode:
4380: 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 20 20 20 " testmode...
4390: 20 20 20 22 5c 6e 20 28 65 71 3f 20 74 65 73 74 "\n (eq? test
43a0: 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 3a mode 'toplevel):
43b0: 20 22 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 " (eq? testmode
43c0: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 20 20 'toplevel)...
43d0: 20 20 20 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 6e "\n (null? n
43e0: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 3a 20 20 on-completed):
43f0: 20 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 " (null? non-c
4400: 6f 6d 70 6c 65 74 65 64 29 0a 09 09 20 20 20 20 ompleted)...
4410: 20 20 22 5c 6e 20 72 65 72 75 6e 73 3a 20 20 20 "\n reruns:
4420: 20 20 20 20 20 20 20 22 20 72 65 72 75 6e 73 0a " reruns.
4430: 09 09 20 20 20 20 20 20 22 5c 6e 20 69 74 65 6d .. "\n item
4440: 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 69 s: " i
4450: 74 65 6d 73 0a 09 09 20 20 20 20 20 20 22 5c 6e tems... "\n
4460: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 can-run-more:
4470: 20 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 " can-run-more
4480: 29 0a 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 ).. (cond.
4490: 20 20 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 ;; all prereqs
44a0: 20 6d 65 74 2c 20 66 69 72 65 20 6f 66 66 20 74 met, fire off t
44b0: 68 65 20 74 65 73 74 0a 20 20 20 20 20 3b 3b 20 he test. ;;
44c0: 6f 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 27 or, if it is a '
44d0: 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 6e toplevel test an
44e0: 64 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f d all prereqs no
44f0: 74 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 t met are COMPLE
4500: 54 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a TED then launch.
4510: 20 20 20 20 20 0a 20 20 20 20 20 28 28 6d 65 6d . ((mem
4520: 62 65 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ber (hash-table-
4530: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
4540: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
4550: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
4560: 61 6d 65 20 68 65 64 20 69 74 65 6d 2d 70 61 74 ame hed item-pat
4570: 68 29 20 27 6e 2f 61 29 0a 09 20 20 20 20 20 20 h) 'n/a)..
4580: 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f 76 '(DONOTRUN remov
4590: 65 64 29 29 20 3b 3b 20 2a 63 6f 6d 6d 6f 6e 3a ed)) ;; *common:
45a0: 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 2d cant-run-states-
45b0: 73 79 6d 2a 29 20 3b 3b 20 27 28 43 4f 4d 50 4c sym*) ;; '(COMPL
45c0: 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 41 49 56 ETED KILLED WAIV
45d0: 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e 43 4f 4d ED UNKNOWN INCOM
45e0: 50 4c 45 54 45 29 29 20 3b 3b 20 74 72 79 20 74 PLETE)) ;; try t
45f0: 6f 20 63 61 74 63 68 20 72 65 70 65 61 74 20 70 o catch repeat p
4600: 72 6f 63 65 73 73 69 6e 67 20 6f 66 20 43 4f 4d rocessing of COM
4610: 50 4c 45 54 45 44 20 74 65 73 74 73 20 68 65 72 PLETED tests her
4620: 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 e. (debug:p
4630: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 54 65 73 rint-info 1 "Tes
4640: 74 20 22 20 68 65 64 20 22 20 73 65 74 20 74 6f t " hed " set to
4650: 20 5c 22 22 20 28 68 61 73 68 2d 74 61 62 6c 65 \"" (hash-table
4660: 2d 72 65 66 20 74 65 73 74 2d 72 65 67 69 73 74 -ref test-regist
4670: 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 ry (runs:make-fu
4680: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 ll-test-name hed
4690: 20 69 74 65 6d 2d 70 61 74 68 29 29 20 22 5c 22 item-path)) "\"
46a0: 2e 20 52 65 6d 6f 76 69 6e 67 20 69 74 20 66 72 . Removing it fr
46b0: 6f 6d 20 74 68 65 20 71 75 65 75 65 22 29 0a 20 om the queue").
46c0: 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f (if (or (no
46d0: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
46e0: 20 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c (not (null
46f0: 3f 20 72 65 67 29 29 29 0a 09 20 20 28 6c 69 73 ? reg))).. (lis
4700: 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 t (runs:queue-ne
4710: 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 xt-hed tal reg r
4720: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
4730: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
4740: 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 65 t-tal tal reg re
4750: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
4760: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
4770: 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 -reg tal reg reg
4780: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 72 len regfull)...r
4790: 65 72 75 6e 73 29 0a 09 20 20 28 62 65 67 69 6e eruns).. (begin
47a0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
47b0: 6e 74 2d 69 6e 66 6f 20 30 20 22 4e 6f 74 68 69 nt-info 0 "Nothi
47c0: 6e 67 20 6c 65 66 74 20 69 6e 20 74 68 65 20 71 ng left in the q
47d0: 75 65 75 65 21 22 29 0a 09 20 20 20 20 3b 3b 20 ueue!").. ;;
47e0: 49 66 20 67 65 74 20 68 65 72 65 20 74 77 69 63 If get here twic
47f0: 65 20 74 68 65 6e 20 77 65 20 6b 6e 6f 77 20 77 e then we know w
4800: 65 27 76 65 20 74 72 69 65 64 20 74 6f 20 65 78 e've tried to ex
4810: 70 61 6e 64 20 61 6c 6c 20 69 74 65 6d 73 0a 09 pand all items..
4820: 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 74 68 65 ;; since the
4830: 72 65 20 6d 75 73 74 20 62 65 20 61 20 6c 6f 67 re must be a log
4840: 69 63 20 69 73 73 75 65 20 77 69 74 68 20 74 68 ic issue with th
4850: 65 20 68 61 6e 64 6c 69 6e 67 20 6f 66 20 6c 6f e handling of lo
4860: 6f 70 73 20 69 6e 20 74 68 65 20 0a 09 20 20 20 ops in the ..
4870: 20 3b 3b 20 69 74 65 6d 73 20 65 78 70 61 6e 64 ;; items expand
4880: 20 70 68 61 73 65 20 77 65 20 77 69 6c 6c 20 62 phase we will b
4890: 72 75 74 65 20 66 6f 72 63 65 20 61 6e 20 65 78 rute force an ex
48a0: 69 74 20 68 65 72 65 2e 0a 09 20 20 20 20 28 69 it here... (i
48b0: 66 20 28 3e 20 72 75 6e 73 3a 6e 6f 74 68 69 6e f (> runs:nothin
48c0: 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 65 75 65 2d g-left-in-queue-
48d0: 63 6f 75 6e 74 20 32 29 0a 09 09 28 62 65 67 69 count 2)...(begi
48e0: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
48f0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 nt 0 "WARNING: t
4900: 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 20 69 73 his condition is
4910: 20 74 72 69 67 67 65 72 65 64 20 77 68 65 6e 20 triggered when
4920: 74 68 65 72 65 20 77 65 72 65 20 6e 6f 20 69 74 there were no it
4930: 65 6d 73 20 74 6f 20 65 78 70 61 6e 64 20 61 6e ems to expand an
4940: 64 20 6e 6f 74 68 69 6e 67 20 74 6f 20 72 75 6e d nothing to run
4950: 2e 20 50 6c 65 61 73 65 20 63 68 65 63 6b 20 79 . Please check y
4960: 6f 75 72 20 72 75 6e 20 66 6f 72 20 63 6f 6d 70 our run for comp
4970: 6c 65 74 65 6e 65 73 73 22 29 0a 09 09 20 20 28 leteness")... (
4980: 65 78 69 74 20 30 29 29 0a 09 09 28 73 65 74 21 exit 0))...(set!
4990: 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 runs:nothing-le
49a0: 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e ft-in-queue-coun
49b0: 74 20 28 2b 20 72 75 6e 73 3a 6e 6f 74 68 69 6e t (+ runs:nothin
49c0: 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 65 75 65 2d g-left-in-queue-
49d0: 63 6f 75 6e 74 20 31 29 29 29 0a 09 20 20 20 20 count 1)))..
49e0: 23 66 29 29 29 0a 0a 20 20 20 20 20 3b 3b 20 0a #f))).. ;; .
49f0: 20 20 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f ((or (null?
4a00: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
4a10: 29 0a 09 20 20 28 61 6e 64 20 28 65 71 3f 20 74 ).. (and (eq? t
4a20: 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 estmode 'topleve
4a30: 6c 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6c 6c l).. (null
4a40: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
4a50: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
4a60: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 print-info 4 "ru
4a70: 6e 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d 73 3a ns:expand-items:
4a80: 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 (or (null? prer
4a90: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 28 61 6e eqs-not-met) (an
4aa0: 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 d (eq? testmode
4ab0: 27 74 6f 70 6c 65 76 65 6c 29 28 6e 75 6c 6c 3f 'toplevel)(null?
4ac0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 non-completed))
4ad0: 29 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 )"). (let (
4ae0: 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 74 (test-name (test
4af0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
4b00: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
4b10: 63 6f 72 64 29 29 29 0a 09 28 73 65 74 65 6e 76 cord)))..(setenv
4b20: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
4b30: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 test-name) ;; ..
4b40: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
4b50: 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a AME" runname).
4b60: 09 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 .(set-megatest-e
4b70: 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 69 nv-vars run-id i
4b80: 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d nrunname: runnam
4b90: 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 e) ;; these may
4ba0: 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 be needed by the
4bb0: 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 launching proce
4bc0: 73 73 0a 09 28 6c 65 74 20 28 28 69 74 65 6d 73 ss..(let ((items
4bd0: 2d 6c 69 73 74 20 28 69 74 65 6d 73 3a 67 65 74 -list (items:get
4be0: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
4bf0: 69 67 20 74 63 6f 6e 66 69 67 29 29 29 0a 09 20 ig tconfig)))..
4c00: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
4c10: 73 2d 6c 69 73 74 29 0a 09 20 20 20 20 20 20 28 s-list).. (
4c20: 62 65 67 69 6e 0a 09 09 28 74 65 73 74 73 3a 74 begin...(tests:t
4c30: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
4c40: 6d 73 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ms! test-record
4c50: 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 28 6c items-list)...(l
4c60: 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 ist hed tal reg
4c70: 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 reruns))..
4c80: 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 3a (begin...(debug:
4c90: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
4ca0: 54 68 65 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 The proc from re
4cb0: 61 64 69 6e 67 20 74 68 65 20 73 65 74 75 70 20 ading the setup
4cc0: 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 did not yield a
4cd0: 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 65 list - please re
4ce0: 70 6f 72 74 20 74 68 69 73 22 29 0a 09 09 28 65 port this")...(e
4cf0: 78 69 74 20 31 29 29 29 29 29 29 0a 0a 20 20 20 xit 1))))))..
4d00: 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 66 ((and (null? f
4d10: 61 69 6c 73 29 0a 09 20 20 20 28 6e 6f 74 20 28 ails).. (not (
4d20: 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 null? non-comple
4d30: 74 65 64 29 29 29 0a 20 20 20 20 20 20 28 6c 65 ted))). (le
4d40: 74 2a 20 28 28 61 6c 6c 69 6e 71 75 65 75 65 20 t* ((allinqueue
4d50: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
4d60: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 78 29 20 (if (string? x)
4d70: 78 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 x (db:test-get-t
4d80: 65 73 74 6e 61 6d 65 20 78 29 29 29 0a 20 20 20 estname x))).
4d90: 20 20 20 20 20 09 09 20 20 20 20 20 20 28 61 70 .. (ap
4da0: 70 65 6e 64 20 6e 65 77 74 61 6c 20 72 65 72 75 pend newtal reru
4db0: 6e 73 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 70 ns))).. ;; p
4dc0: 72 65 72 65 71 73 74 72 73 20 69 73 20 61 20 6c rereqstrs is a l
4dd0: 69 73 74 20 6f 66 20 74 65 73 74 20 6e 61 6d 65 ist of test name
4de0: 73 20 61 73 20 73 74 72 69 6e 67 73 20 74 68 61 s as strings tha
4df0: 74 20 61 72 65 20 70 72 65 72 65 71 73 20 66 6f t are prereqs fo
4e00: 72 20 68 65 64 0a 20 20 20 20 20 20 20 20 20 20 r hed.
4e10: 20 20 20 28 70 72 65 72 65 71 73 74 72 73 20 28 (prereqstrs (
4e20: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
4e30: 73 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 s (map (lambda (
4e40: 78 29 28 69 66 20 28 73 74 72 69 6e 67 3f 20 78 x)(if (string? x
4e50: 29 20 78 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ) x (db:test-get
4e60: 2d 74 65 73 74 6e 61 6d 65 20 78 29 29 29 0a 09 -testname x)))..
4e70: 09 09 09 09 09 20 70 72 65 72 65 71 73 2d 6e 6f ..... prereqs-no
4e80: 74 2d 6d 65 74 29 29 29 0a 09 20 20 20 20 20 3b t-met))).. ;
4e90: 3b 20 61 20 70 72 65 72 65 71 20 74 68 61 74 20 ; a prereq that
4ea0: 69 73 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 is not found in
4eb0: 61 6c 6c 69 6e 71 75 65 75 65 20 77 69 6c 6c 20 allinqueue will
4ec0: 62 65 20 70 75 74 20 69 6e 20 74 68 65 20 6e 6f be put in the no
4ed0: 74 69 6e 71 75 65 75 65 20 6c 69 73 74 0a 09 20 tinqueue list..
4ee0: 20 20 20 20 3b 3b 20 0a 20 20 20 20 20 20 20 20 ;; .
4ef0: 20 20 20 20 20 3b 3b 20 28 6e 6f 74 69 6e 71 75 ;; (notinqu
4f00: 65 75 65 20 28 66 69 6c 74 65 72 20 28 6c 61 6d eue (filter (lam
4f10: 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 bda (x).
4f20: 20 20 20 20 20 3b 3b 20 20 20 20 09 09 20 20 20 ;; ..
4f30: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 78 20 61 (not (member x a
4f40: 6c 6c 69 6e 71 75 65 75 65 29 29 29 0a 20 20 20 llinqueue))).
4f50: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 ;;
4f60: 09 09 20 70 72 65 72 65 71 73 74 72 73 29 29 0a .. prereqstrs)).
4f70: 09 20 20 20 20 20 28 67 69 76 65 2d 75 70 20 20 . (give-up
4f80: 20 20 23 66 29 29 0a 0a 09 3b 3b 20 57 65 20 63 #f))...;; We c
4f90: 61 6e 20 67 65 74 20 68 65 72 65 20 77 68 65 6e an get here when
4fa0: 20 61 20 70 72 65 72 65 71 20 68 61 73 20 6e 6f a prereq has no
4fb0: 74 20 62 65 65 6e 20 72 75 6e 20 64 75 65 20 74 t been run due t
4fc0: 6f 20 2a 69 74 2a 20 68 61 76 69 6e 67 20 61 20 o *it* having a
4fd0: 70 72 65 72 65 71 20 74 68 61 74 20 66 61 69 6c prereq that fail
4fe0: 65 64 2e 0a 09 3b 3b 20 57 65 20 6e 65 65 64 20 ed...;; We need
4ff0: 74 6f 20 75 73 65 20 74 68 69 73 20 74 6f 20 64 to use this to d
5000: 65 71 75 65 75 65 20 74 68 69 73 20 69 74 65 6d equeue this item
5010: 20 61 73 20 43 41 4e 4e 4f 54 52 55 4e 0a 09 28 as CANNOTRUN..(
5020: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
5030: 20 28 70 72 65 72 65 71 29 0a 09 09 20 20 20 20 (prereq)...
5040: 28 69 66 20 28 65 71 3f 20 28 68 61 73 68 2d 74 (if (eq? (hash-t
5050: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5060: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 70 test-registry p
5070: 72 65 72 65 71 20 27 6a 75 73 74 66 69 6e 65 29 rereq 'justfine)
5080: 20 27 43 41 4e 4e 4f 54 52 55 4e 29 0a 09 09 09 'CANNOTRUN)....
5090: 28 73 65 74 21 20 67 69 76 65 2d 75 70 20 23 74 (set! give-up #t
50a0: 29 29 29 0a 09 09 20 20 70 72 65 72 65 71 73 74 )))... prereqst
50b0: 72 73 29 0a 09 28 69 66 20 28 61 6e 64 20 67 69 rs)..(if (and gi
50c0: 76 65 2d 75 70 0a 09 09 20 28 6e 6f 74 20 28 61 ve-up... (not (a
50d0: 6e 64 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e nd (null? tal)(n
50e0: 75 6c 6c 3f 20 72 65 67 29 29 29 29 0a 09 20 20 ull? reg))))..
50f0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
5100: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
5110: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 WARNING: test "
5120: 68 65 64 20 22 20 68 61 73 20 6e 6f 20 64 69 73 hed " has no dis
5130: 63 61 72 64 65 64 20 70 72 65 72 65 71 75 69 73 carded prerequis
5140: 69 74 65 73 2c 20 72 65 6d 6f 76 69 6e 67 20 69 ites, removing i
5150: 74 20 66 72 6f 6d 20 74 68 65 20 71 75 65 75 65 t from the queue
5160: 22 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 ").. (list
5170: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
5180: 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 -hed tal reg reg
5190: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 len regfull)...
51a0: 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e (runs:queue-n
51b0: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
51c0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
51d0: 09 09 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 .. (runs:queu
51e0: 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 e-next-reg tal r
51f0: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
5200: 6c 29 0a 09 09 20 20 20 20 72 65 72 75 6e 73 29 l)... reruns)
5210: 29 0a 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 ).. (list (ca
5220: 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e 64 r newtal)(append
5230: 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 (cdr newtal) re
5240: 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 29 29 g) '() reruns)))
5250: 29 0a 0a 0a 20 20 20 20 20 3b 3b 20 28 64 65 62 )... ;; (deb
5260: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
5270: 22 61 6c 6c 69 6e 71 75 65 75 65 3a 20 22 20 61 "allinqueue: " a
5280: 6c 6c 69 6e 71 75 65 75 65 29 0a 20 20 20 20 20 llinqueue).
5290: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ;; (debug:print-
52a0: 69 6e 66 6f 20 31 20 22 70 72 65 72 65 71 73 74 info 1 "prereqst
52b0: 72 73 3a 20 22 20 70 72 65 72 65 71 73 74 72 73 rs: " prereqstrs
52c0: 29 0a 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ). ;; (debug
52d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 6e :print-info 1 "n
52e0: 6f 74 69 6e 71 75 65 75 65 3a 20 22 20 6e 6f 74 otinqueue: " not
52f0: 69 6e 71 75 65 75 65 29 0a 20 20 20 20 20 3b 3b inqueue). ;;
5300: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5310: 66 6f 20 31 20 22 74 61 6c 3a 20 20 20 20 20 20 fo 1 "tal:
5320: 20 20 22 20 74 61 6c 29 0a 20 20 20 20 20 3b 3b " tal). ;;
5330: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5340: 66 6f 20 31 20 22 6e 65 77 74 61 6c 3a 20 20 20 fo 1 "newtal:
5350: 20 20 22 20 6e 65 77 74 61 6c 29 0a 20 20 20 20 " newtal).
5360: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5370: 2d 69 6e 66 6f 20 31 20 22 72 65 67 3a 20 20 20 -info 1 "reg:
5380: 20 20 20 20 20 22 20 72 65 67 29 0a 0a 3b 3b 20 " reg)..;;
5390: 3d 3d 20 3d 3d 20 20 20 20 20 20 20 3b 3b 20 6e == == ;; n
53a0: 75 6d 2d 72 65 74 72 69 65 73 20 63 6f 64 65 20 um-retries code
53b0: 77 61 73 20 68 65 72 65 0a 3b 3b 20 3d 3d 20 3d was here.;; == =
53c0: 3d 20 20 20 20 20 20 20 3b 3b 20 77 65 20 75 73 = ;; we us
53d0: 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 e this opportuni
53e0: 74 79 20 74 6f 20 6d 6f 76 65 20 63 6f 6e 74 65 ty to move conte
53f0: 6e 74 73 20 6f 66 20 72 65 67 20 74 6f 20 74 61 nts of reg to ta
5400: 6c 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 l.;; == ==
5410: 20 3b 3b 20 62 75 74 20 61 6c 73 6f 20 6c 65 74 ;; but also let
5420: 73 20 63 68 65 63 6b 20 74 68 61 74 20 74 68 65 s check that the
5430: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 61 prerequisites a
5440: 72 65 20 61 6c 6c 20 69 6e 20 74 68 65 20 6e 65 re all in the ne
5450: 77 74 61 6c 20 6f 72 20 72 65 72 75 6e 73 20 6c wtal or reruns l
5460: 69 73 74 73 0a 3b 3b 20 3d 3d 20 3d 3d 20 0a 3b ists.;; == == .;
5470: 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 28 6c ; == == (l
5480: 65 74 2a 20 28 28 61 6c 6c 69 6e 71 75 65 75 65 et* ((allinqueue
5490: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
54a0: 29 28 69 66 20 28 73 74 72 69 6e 67 3f 20 78 29 )(if (string? x)
54b0: 20 78 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d x (db:test-get-
54c0: 74 65 73 74 6e 61 6d 65 20 78 29 29 29 0a 3b 3b testname x))).;;
54d0: 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 20 20 09 == == .
54e0: 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 6e . (append n
54f0: 65 77 74 61 6c 20 72 65 72 75 6e 73 29 29 29 0a ewtal reruns))).
5500: 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 20 20 20 3b ;; == == . ;
5510: 3b 20 70 72 65 72 65 71 73 74 72 73 20 69 73 20 ; prereqstrs is
5520: 61 20 6c 69 73 74 20 6f 66 20 74 65 73 74 20 6e a list of test n
5530: 61 6d 65 73 20 61 73 20 73 74 72 69 6e 67 73 20 ames as strings
5540: 74 68 61 74 20 61 72 65 20 70 72 65 72 65 71 73 that are prereqs
5550: 20 66 6f 72 20 68 65 64 0a 3b 3b 20 3d 3d 20 3d for hed.;; == =
5560: 3d 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 = (
5570: 70 72 65 72 65 71 73 74 72 73 20 28 6d 61 70 20 prereqstrs (map
5580: 28 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 (lambda (x)(if (
5590: 73 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 string? x) x (db
55a0: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
55b0: 6d 65 20 78 29 29 29 0a 3b 3b 20 3d 3d 20 3d 3d me x))).;; == ==
55c0: 20 20 20 20 20 20 20 20 20 09 09 20 20 20 20 20 ..
55d0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
55e0: 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 20 )).;; == == .
55f0: 20 20 3b 3b 20 61 20 70 72 65 72 65 71 20 74 68 ;; a prereq th
5600: 61 74 20 69 73 20 6e 6f 74 20 66 6f 75 6e 64 20 at is not found
5610: 69 6e 20 61 6c 6c 69 6e 71 75 65 75 65 20 77 69 in allinqueue wi
5620: 6c 6c 20 62 65 20 70 75 74 20 69 6e 20 74 68 65 ll be put in the
5630: 20 6e 6f 74 69 6e 71 75 65 75 65 20 6c 69 73 74 notinqueue list
5640: 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 20 20 20 .;; == == .
5650: 3b 3b 20 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 ;; .;; == ==
5660: 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 69 6e (notin
5670: 71 75 65 75 65 20 28 66 69 6c 74 65 72 20 28 6c queue (filter (l
5680: 61 6d 62 64 61 20 28 78 29 0a 3b 3b 20 3d 3d 20 ambda (x).;; ==
5690: 3d 3d 20 20 20 20 20 20 20 20 20 09 09 09 20 20 == ...
56a0: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 78 20 (not (member x
56b0: 61 6c 6c 69 6e 71 75 65 75 65 29 29 29 0a 3b 3b allinqueue))).;;
56c0: 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 20 20 09 == == .
56d0: 09 09 20 70 72 65 72 65 71 73 74 72 73 29 29 29 .. prereqstrs)))
56e0: 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 .;; == ==
56f0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
5700: 3f 20 6e 6f 74 69 6e 71 75 65 75 65 29 29 0a 3b ? notinqueue)).;
5710: 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 20 20 ; == ==
5720: 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 63 61 (if (runs:ca
5730: 6e 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 3f 20 n-keep-running?
5740: 68 65 64 20 35 29 20 3b 3b 20 74 72 79 20 66 69 hed 5) ;; try fi
5750: 76 65 20 74 69 6d 65 73 0a 3b 3b 20 3d 3d 20 3d ve times.;; == =
5760: 3d 20 20 20 20 20 20 20 20 20 09 28 62 65 67 69 = .(begi
5770: 6e 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 20 20 28 n.;; == == .. (
5780: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5790: 20 34 20 22 69 6e 63 72 65 6d 65 6e 74 20 63 61 4 "increment ca
57a0: 6e 74 2d 72 75 6e 2d 74 65 73 74 73 20 66 6f 72 nt-run-tests for
57b0: 20 22 20 68 65 64 29 0a 3b 3b 20 3d 3d 20 3d 3d " hed).;; == ==
57c0: 20 20 20 20 20 20 20 20 20 09 20 20 28 72 75 6e . (run
57d0: 73 3a 69 6e 63 2d 63 61 6e 74 2d 72 75 6e 2d 74 s:inc-cant-run-t
57e0: 65 73 74 73 20 68 65 64 29 0a 3b 3b 20 3d 3d 20 ests hed).;; ==
57f0: 3d 3d 20 20 20 20 20 20 20 20 20 09 20 20 28 6c == . (l
5800: 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 ist (car newtal)
5810: 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e 65 77 (append (cdr new
5820: 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 72 65 tal) reg) '() re
5830: 72 75 6e 73 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 runs)).;; == ==
5840: 20 20 20 20 20 20 20 20 09 28 62 65 67 69 6e 0a .(begin.
5850: 3b 3b 20 3d 3d 20 3d 3d 20 09 09 20 20 0a 3b 3b ;; == == .. .;;
5860: 20 3d 3d 20 3d 3d 20 09 09 20 20 28 69 66 20 28 == == .. (if (
5870: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 runs:lownoise (c
5880: 6f 6e 63 20 22 6e 6f 20 66 61 69 6c 73 20 70 72 onc "no fails pr
5890: 65 72 65 71 2c 20 6e 75 6c 6c 20 6e 6f 74 69 6e ereq, null notin
58a0: 71 75 65 75 65 20 22 20 68 65 64 29 20 33 30 29 queue " hed) 30)
58b0: 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 20 20 20 20 .;; == == ..
58c0: 20 20 28 62 65 67 69 6e 0a 3b 3b 20 3d 3d 20 3d (begin.;; == =
58d0: 3d 20 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e = ...(debug:prin
58e0: 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 t 1 "WARNING: te
58f0: 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 6e st " hed " has n
5900: 6f 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 o failed prerequ
5910: 69 73 69 74 65 73 20 62 75 74 20 64 6f 65 73 20 isites but does
5920: 68 61 76 65 20 70 72 65 72 65 71 75 69 73 74 65 have prerequiste
5930: 73 20 74 68 61 74 20 61 72 65 20 4e 4f 54 20 69 s that are NOT i
5940: 6e 20 74 68 65 20 71 75 65 75 65 3a 20 22 20 28 n the queue: " (
5950: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
5960: 73 65 20 6e 6f 74 69 6e 71 75 65 75 65 20 22 2c se notinqueue ",
5970: 20 22 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 ")).;; == == ..
5980: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
5990: 66 6f 20 34 20 22 61 6c 6c 69 6e 71 75 65 75 65 fo 4 "allinqueue
59a0: 3a 20 22 20 61 6c 6c 69 6e 71 75 65 75 65 29 0a : " allinqueue).
59b0: 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 28 64 65 62 ;; == == ...(deb
59c0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
59d0: 22 70 72 65 72 65 71 73 74 72 73 3a 20 22 20 70 "prereqstrs: " p
59e0: 72 65 72 65 71 73 74 72 73 29 0a 3b 3b 20 3d 3d rereqstrs).;; ==
59f0: 20 3d 3d 20 09 09 09 28 64 65 62 75 67 3a 70 72 == ...(debug:pr
5a00: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 6e 6f 74 69 int-info 4 "noti
5a10: 6e 71 75 65 75 65 3a 20 22 20 6e 6f 74 69 6e 71 nqueue: " notinq
5a20: 75 65 75 65 29 29 29 0a 3b 3b 20 3d 3d 20 3d 3d ueue))).;; == ==
5a30: 20 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e .. (if (and (n
5a40: 75 6c 6c 3f 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 ull? tal)(null?
5a50: 72 65 67 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 reg)).;; == == .
5a60: 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 . (list (ca
5a70: 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e 64 r newtal)(append
5a80: 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 (cdr newtal) re
5a90: 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 0a 3b g) '() reruns).;
5aa0: 3b 20 3d 3d 20 3d 3d 20 09 09 20 20 20 20 20 20 ; == == ..
5ab0: 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 (list (runs:queu
5ac0: 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 e-next-hed tal r
5ad0: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
5ae0: 6c 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 20 l).;; == == ...
5af0: 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e (runs:queue-n
5b00: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
5b10: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
5b20: 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 20 20 20 20 ;; == == ...
5b30: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
5b40: 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 -reg tal reg reg
5b50: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 3b 3b 20 len regfull).;;
5b60: 3d 3d 20 3d 3d 20 09 09 09 20 20 20 20 72 65 72 == == ... rer
5b70: 75 6e 73 29 29 29 29 0a 3b 3b 20 3d 3d 20 3d 3d uns)))).;; == ==
5b80: 20 09 20 20 20 20 3b 3b 20 68 61 76 65 20 70 72 . ;; have pr
5b90: 65 72 65 71 73 20 69 6e 20 71 75 65 75 65 2c 20 ereqs in queue,
5ba0: 6b 65 65 70 20 67 6f 69 6e 67 2e 0a 3b 3b 20 3d keep going..;; =
5bb0: 3d 20 3d 3d 20 09 20 20 20 20 28 62 65 67 69 6e = == . (begin
5bc0: 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 20 20 20 .;; == == .
5bd0: 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f (if (runs:lowno
5be0: 69 73 65 20 28 63 6f 6e 63 20 22 6e 6f 20 66 61 ise (conc "no fa
5bf0: 69 6c 73 20 70 72 65 72 65 71 20 22 20 68 65 64 ils prereq " hed
5c00: 29 20 33 30 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 ) 30).;; == == .
5c10: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
5c20: 69 6e 66 6f 20 31 20 22 6e 6f 20 66 61 69 6c 73 info 1 "no fails
5c30: 20 69 6e 20 70 72 65 72 65 71 75 69 73 69 74 65 in prerequisite
5c40: 73 20 66 6f 72 20 22 20 68 65 64 20 22 2c 20 77 s for " hed ", w
5c50: 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 3b aiting on tests;
5c60: 20 22 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 09 ".;; == == ....
5c70: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
5c80: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
5c90: 6d 62 64 61 20 28 78 29 0a 3b 3b 20 3d 3d 20 3d mbda (x).;; == =
5ca0: 3d 20 09 09 09 09 09 09 09 20 20 20 20 20 20 20 = .......
5cb0: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 78 29 0a (if (string? x).
5cc0: 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 09 09 09 09 ;; == == .......
5cd0: 09 20 20 20 78 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 . x.;; == == .
5ce0: 09 09 09 09 09 09 09 20 20 20 28 72 75 6e 73 3a ....... (runs:
5cf0: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
5d00: 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ame (db:test-get
5d10: 2d 74 65 73 74 6e 61 6d 65 20 78 29 0a 3b 3b 20 -testname x).;;
5d20: 3d 3d 20 3d 3d 20 09 09 09 09 09 09 09 09 09 09 == == ..........
5d30: 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 . (db:test-g
5d40: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 78 29 29 et-item-path x))
5d50: 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 09 )).;; == == ....
5d60: 09 09 09 20 20 20 20 20 6e 6f 6e 2d 63 6f 6d 70 ... non-comp
5d70: 6c 65 74 65 64 29 20 22 2c 20 22 29 0a 3b 3b 20 leted) ", ").;;
5d80: 3d 3d 20 3d 3d 20 09 09 09 09 20 20 20 20 22 2e == == .... ".
5d90: 20 44 65 6c 61 79 69 6e 67 20 6c 61 75 6e 63 68 Delaying launch
5da0: 20 6f 66 20 22 20 68 65 64 20 22 2e 22 29 29 0a of " hed ".")).
5db0: 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 20 20 20 20 ;; == == .
5dc0: 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 (list (car newta
5dd0: 6c 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e l)(append (cdr n
5de0: 65 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 ewtal) reg) '()
5df0: 72 65 72 75 6e 73 29 29 29 29 29 20 3b 3b 20 61 reruns))))) ;; a
5e00: 6e 20 69 73 73 75 65 20 77 69 74 68 20 70 72 65 n issue with pre
5e10: 72 65 71 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 reqs not yet met
5e20: 3f 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e ?.. ((and (n
5e30: 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 20 20 20 ull? fails)..
5e40: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl
5e50: 65 74 65 64 29 29 0a 20 20 20 20 20 20 28 69 66 eted)). (if
5e60: 20 20 28 72 75 6e 73 3a 63 61 6e 2d 6b 65 65 70 (runs:can-keep
5e70: 2d 72 75 6e 6e 69 6e 67 3f 20 68 65 64 20 35 29 -running? hed 5)
5e80: 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
5e90: 28 72 75 6e 73 3a 69 6e 63 2d 63 61 6e 74 2d 72 (runs:inc-cant-r
5ea0: 75 6e 2d 74 65 73 74 73 20 68 65 64 29 0a 09 20 un-tests hed)..
5eb0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5ec0: 69 6e 66 6f 20 31 20 22 6e 6f 20 66 61 69 6c 73 info 1 "no fails
5ed0: 20 69 6e 20 70 72 65 72 65 71 75 69 73 69 74 65 in prerequisite
5ee0: 73 20 66 6f 72 20 22 20 68 65 64 20 22 20 62 75 s for " hed " bu
5ef0: 74 20 61 6c 73 6f 20 6e 6f 6e 65 20 72 75 6e 6e t also none runn
5f00: 69 6e 67 2c 20 6b 65 65 70 69 6e 67 20 22 20 68 ing, keeping " h
5f10: 65 64 20 22 20 66 6f 72 20 6e 6f 77 2e 20 54 72 ed " for now. Tr
5f20: 79 20 63 6f 75 6e 74 3a 20 22 20 28 68 61 73 68 y count: " (hash
5f30: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5f40: 6c 74 20 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 lt *seen-cant-ru
5f50: 6e 2d 74 65 73 74 73 2a 20 68 65 64 20 30 29 29 n-tests* hed 0))
5f60: 0a 09 20 20 20 20 3b 3b 20 6e 75 6d 2d 72 65 74 .. ;; num-ret
5f70: 72 69 65 73 20 63 6f 64 65 20 77 61 73 20 68 65 ries code was he
5f80: 72 65 0a 09 20 20 20 20 3b 3b 20 77 65 20 75 73 re.. ;; we us
5f90: 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 e this opportuni
5fa0: 74 79 20 74 6f 20 6d 6f 76 65 20 63 6f 6e 74 65 ty to move conte
5fb0: 6e 74 73 20 6f 66 20 72 65 67 20 74 6f 20 74 61 nts of reg to ta
5fc0: 6c 0a 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 l.. (list (ca
5fd0: 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e 64 r newtal)(append
5fe0: 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 (cdr newtal) re
5ff0: 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 29 20 g) '() reruns))
6000: 3b 3b 20 61 6e 20 69 73 73 75 65 20 77 69 74 68 ;; an issue with
6010: 20 70 72 65 72 65 71 73 20 6e 6f 74 20 79 65 74 prereqs not yet
6020: 20 6d 65 74 3f 0a 09 20 20 28 62 65 67 69 6e 0a met?.. (begin.
6030: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
6040: 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 66 61 69 t-info 1 "no fai
6050: 6c 73 20 69 6e 20 70 72 65 72 65 71 75 69 73 69 ls in prerequisi
6060: 74 65 73 20 66 6f 72 20 22 20 68 65 64 20 22 20 tes for " hed "
6070: 62 75 74 20 6e 6f 74 68 69 6e 67 20 73 65 65 6e but nothing seen
6080: 20 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 77 68 running in a wh
6090: 69 6c 65 2c 20 64 72 6f 70 70 69 6e 67 20 74 65 ile, dropping te
60a0: 73 74 20 22 20 68 65 64 20 22 20 66 72 6f 6d 20 st " hed " from
60b0: 74 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 0a the run queue").
60c0: 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 . (list (runs
60d0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
60e0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
60f0: 65 67 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e egfull)... (run
6100: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
6110: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
6120: 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 28 72 75 regfull)... (ru
6130: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 ns:queue-next-re
6140: 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e g tal reg reglen
6150: 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 72 65 regfull)... re
6160: 72 75 6e 73 29 29 29 29 0a 0a 20 20 20 20 20 28 runs)))).. (
6170: 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
6180: 20 66 61 69 6c 73 29 29 28 65 71 3f 20 74 65 73 fails))(eq? tes
6190: 74 6d 6f 64 65 20 27 6e 6f 72 6d 61 6c 29 29 0a tmode 'normal)).
61a0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
61b0: 6e 74 2d 69 6e 66 6f 20 31 20 22 74 65 73 74 20 nt-info 1 "test
61c0: 22 20 20 68 65 64 20 22 20 28 6d 6f 64 65 3d 22 " hed " (mode="
61d0: 20 74 65 73 74 6d 6f 64 65 20 22 29 20 68 61 73 testmode ") has
61e0: 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 69 failed prerequi
61f0: 73 69 74 65 28 73 29 3b 20 22 0a 09 09 09 28 73 site(s); "....(s
6200: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
6210: 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
6220: 74 29 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 t)(conc (db:test
6230: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 -get-testname t)
6240: 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 ":" (db:test-ge
6250: 74 2d 73 74 61 74 65 20 74 29 22 2f 22 28 64 62 t-state t)"/"(db
6260: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
6270: 20 74 29 29 29 20 66 61 69 6c 73 29 20 22 2c 20 t))) fails) ",
6280: 22 29 0a 09 09 09 22 2c 20 72 65 6d 6f 76 69 6e ")....", removin
6290: 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 6f 20 g it from to-do
62a0: 6c 69 73 74 22 29 0a 20 20 20 20 20 20 28 69 66 list"). (if
62b0: 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (or (not (null?
62c0: 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 6c 6c reg))(not (null
62d0: 3f 20 74 61 6c 29 29 29 0a 09 20 20 28 62 65 67 ? tal))).. (beg
62e0: 69 6e 0a 09 20 20 20 20 28 68 61 73 68 2d 74 61 in.. (hash-ta
62f0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
6300: 67 69 73 74 72 79 20 68 65 64 20 27 43 41 4e 4e gistry hed 'CANN
6310: 4f 54 52 55 4e 29 0a 09 20 20 20 20 28 6c 69 73 OTRUN).. (lis
6320: 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 t (runs:queue-ne
6330: 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 xt-hed tal reg r
6340: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
6350: 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e . (runs:queue-n
6360: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
6370: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
6380: 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d .. (runs:queue-
6390: 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 next-reg tal reg
63a0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
63b0: 0a 09 09 20 20 28 63 6f 6e 73 20 68 65 64 20 72 ... (cons hed r
63c0: 65 72 75 6e 73 29 29 29 0a 09 20 20 23 66 29 29 eruns))).. #f))
63d0: 20 3b 3b 20 23 66 20 66 6c 61 67 73 20 64 6f 20 ;; #f flags do
63e0: 6e 6f 74 20 6c 6f 6f 70 0a 0a 20 20 20 20 20 28 not loop.. (
63f0: 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
6400: 20 66 61 69 6c 73 29 29 28 65 71 3f 20 74 65 73 fails))(eq? tes
6410: 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 tmode 'toplevel)
6420: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 ). (if (or
6430: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
6440: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
6450: 29 29 29 0a 09 20 20 20 28 6c 69 73 74 20 28 63 ))).. (list (c
6460: 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e ar newtal)(appen
6470: 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 d (cdr newtal) r
6480: 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 0a eg) '() reruns).
6490: 09 20 20 23 66 29 29 20 0a 20 20 20 20 20 28 65 . #f)) . (e
64a0: 6c 73 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 lse. (debug
64b0: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e :print 1 "WARNIN
64c0: 47 3a 20 46 41 49 4c 53 20 6f 72 20 69 6e 63 6f G: FAILS or inco
64d0: 6d 70 6c 65 74 65 20 74 65 73 74 73 20 61 72 65 mplete tests are
64e0: 20 70 72 65 76 65 6e 74 69 6e 67 20 63 6f 6d 70 preventing comp
64f0: 6c 65 74 69 6f 6e 20 6f 66 20 74 68 69 73 20 72 letion of this r
6500: 75 6e 2e 20 44 72 6f 70 70 69 6e 67 20 74 65 73 un. Dropping tes
6510: 74 20 22 20 68 65 64 20 22 20 66 72 6f 6d 20 74 t " hed " from t
6520: 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 0a 20 he run queue").
6530: 20 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 (list (runs
6540: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
6550: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
6560: 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a egfull)...(runs:
6570: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
6580: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
6590: 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 gfull)...(runs:q
65a0: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 ueue-next-reg ta
65b0: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
65c0: 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 29 full)...reruns))
65d0: 29 29 29 20 3b 3b 20 28 6c 69 73 74 20 28 63 61 ))) ;; (list (ca
65e0: 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 r newtal)(cdr ne
65f0: 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 wtal) reg reruns
6600: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
6610: 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 2d runs:mixed-list-
6620: 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 73 testname-and-tes
6630: 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 74 trec->list-of-st
6640: 72 69 6e 67 73 20 69 6e 6c 73 74 29 0a 20 20 28 rings inlst). (
6650: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a map (lambda (t).
6660: 09 20 28 63 6f 6e 64 0a 09 20 20 28 28 76 65 63 . (cond.. ((vec
6670: 74 6f 72 3f 20 74 29 0a 09 20 20 20 28 63 6f 6e tor? t).. (con
6680: 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 c (db:test-get-s
6690: 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 3a tate t) "/" (db:
66a0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
66b0: 74 29 29 29 0a 09 20 20 28 28 73 74 72 69 6e 67 t))).. ((string
66c0: 3f 20 74 29 0a 09 20 20 20 74 29 0a 09 20 20 28 ? t).. t).. (
66d0: 65 6c 73 65 20 0a 09 20 20 20 28 63 6f 6e 63 20 else .. (conc
66e0: 74 29 29 29 29 0a 20 20 20 20 20 20 20 69 6e 6c t)))). inl
66f0: 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 st))..(define (r
6700: 75 6e 73 3a 70 72 6f 63 65 73 73 2d 65 78 70 61 uns:process-expa
6710: 6e 64 65 64 2d 74 65 73 74 73 20 68 65 64 20 74 nded-tests hed t
6720: 61 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 al reg reruns re
6730: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 20 74 65 73 glen regfull tes
6740: 74 2d 72 65 63 6f 72 64 20 72 75 6e 6e 61 6d 65 t-record runname
6750: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
6760: 70 61 74 68 20 6a 6f 62 67 72 6f 75 70 20 6d 61 path jobgroup ma
6770: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
6780: 73 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 s run-id waitons
6790: 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d item-path testm
67a0: 6f 64 65 20 74 65 73 74 2d 70 61 74 74 73 20 72 ode test-patts r
67b0: 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 74 65 equired-tests te
67c0: 73 74 2d 72 65 67 69 73 74 72 79 20 72 65 67 69 st-registry regi
67d0: 73 74 72 79 2d 6d 75 74 65 78 20 66 6c 61 67 73 stry-mutex flags
67e0: 20 6b 65 79 76 61 6c 73 20 72 75 6e 2d 69 6e 66 keyvals run-inf
67f0: 6f 20 6e 65 77 74 61 6c 20 61 6c 6c 2d 74 65 73 o newtal all-tes
6800: 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 28 ts-registry). (
6810: 6c 65 74 2a 20 28 28 72 75 6e 2d 6c 69 6d 69 74 let* ((run-limit
6820: 73 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 28 s-info (
6830: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
6840: 65 2d 74 65 73 74 73 20 6a 6f 62 67 72 6f 75 70 e-tests jobgroup
6850: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
6860: 6a 6f 62 73 29 29 20 3b 3b 20 6c 6f 6f 6b 20 61 jobs)) ;; look a
6870: 74 20 74 68 65 20 74 65 73 74 20 6a 6f 62 67 72 t the test jobgr
6880: 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a 6f 62 73 oup and tot jobs
6890: 20 72 75 6e 6e 69 6e 67 0a 09 20 28 68 61 76 65 running.. (have
68a0: 2d 72 65 73 6f 75 72 63 65 73 20 20 20 20 20 20 -resources
68b0: 20 20 20 20 28 63 61 72 20 72 75 6e 2d 6c 69 6d (car run-lim
68c0: 69 74 73 2d 69 6e 66 6f 29 29 0a 09 20 28 6e 75 its-info)).. (nu
68d0: 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 m-running
68e0: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
68f0: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 run-limits-info
6900: 31 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 1)).. (num-runni
6910: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 ng-in-jobgroup (
6920: 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d list-ref run-lim
6930: 69 74 73 2d 69 6e 66 6f 20 32 29 29 20 0a 09 20 its-info 2)) ..
6940: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
6950: 6a 6f 62 73 20 20 20 20 20 28 6c 69 73 74 2d 72 jobs (list-r
6960: 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ef run-limits-in
6970: 66 6f 20 33 29 29 0a 09 20 28 6a 6f 62 2d 67 72 fo 3)).. (job-gr
6980: 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 oup-limit
6990: 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d (list-ref run-
69a0: 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 34 29 29 0a limits-info 4)).
69b0: 09 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d . (prereqs-not-m
69c0: 65 74 20 20 20 20 20 20 20 20 20 28 6d 74 3a 67 et (mt:g
69d0: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
69e0: 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e et run-id waiton
69f0: 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 s item-path mode
6a00: 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 20 28 : testmode)).. (
6a10: 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 fails
6a20: 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 (runs:ca
6a30: 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 lc-fails prereqs
6a40: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 6e 6f -not-met)).. (no
6a50: 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 20 20 n-completed
6a60: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
6a70: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
6a80: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
6a90: 0a 09 20 28 6c 6f 6f 70 2d 6c 69 73 74 20 20 20 .. (loop-list
6aa0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
6ab0: 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t hed tal reg re
6ac0: 72 75 6e 73 29 29 29 0a 20 20 20 20 28 64 65 62 runs))). (deb
6ad0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
6ae0: 22 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 3a "have-resources:
6af0: 20 22 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 " have-resource
6b00: 73 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d s " prereqs-not-
6b10: 6d 65 74 3a 20 28 22 20 0a 09 09 20 20 20 20 20 met: (" ...
6b20: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
6b30: 65 72 73 65 20 0a 09 09 20 20 20 20 20 20 20 28 erse ... (
6b40: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a map (lambda (t).
6b50: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 76 65 ... (if (ve
6b60: 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 20 20 28 ctor? t)..... (
6b70: 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 conc (db:test-ge
6b80: 74 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 t-state t) "/" (
6b90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
6ba0: 75 73 20 74 29 29 0a 09 09 09 09 20 20 28 63 6f us t))..... (co
6bb0: 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a 20 74 20 nc " WARNING: t
6bc0: 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 3d is not a vector=
6bd0: 22 20 74 20 29 29 29 0a 09 09 09 20 20 20 20 70 " t ))).... p
6be0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 rereqs-not-met)
6bf0: 22 2c 20 22 29 20 22 29 20 66 61 69 6c 73 3a 20 ", ") ") fails:
6c00: 22 20 66 61 69 6c 73 29 0a 20 20 20 20 0a 20 20 " fails). .
6c10: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
6c20: 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 ? prereqs-not-me
6c30: 74 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e t))..(debug:prin
6c40: 74 2d 69 6e 66 6f 20 31 20 22 77 61 69 74 69 6e t-info 1 "waitin
6c50: 67 20 6f 6e 20 74 65 73 74 73 3b 20 22 20 28 73 g on tests; " (s
6c60: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
6c70: 65 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 e (runs:mixed-li
6c80: 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d st-testname-and-
6c90: 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 testrec->list-of
6ca0: 2d 73 74 72 69 6e 67 73 20 70 72 65 72 65 71 73 -strings prereqs
6cb0: 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 29 -not-met) ", "))
6cc0: 29 0a 0a 20 20 20 20 3b 3b 20 44 6f 6e 27 74 20 ).. ;; Don't
6cd0: 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 74 69 6d know at this tim
6ce0: 65 20 69 66 20 74 68 65 20 74 65 73 74 20 68 61 e if the test ha
6cf0: 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 64 ve been launched
6d00: 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 6e at some time in
6d10: 20 74 68 65 20 70 61 73 74 0a 20 20 20 20 3b 3b the past. ;;
6d20: 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 61 20 i.e. is this a
6d30: 72 65 2d 6c 61 75 6e 63 68 3f 0a 20 20 20 20 28 re-launch?. (
6d40: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6d50: 20 34 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 4 "run-limits-i
6d60: 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d 69 nfo = " run-limi
6d70: 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 0a 20 20 ts-info). .
6d80: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 0a 20 20 (cond. .
6d90: 20 20 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 6d ;; Check item
6da0: 20 70 61 74 68 20 61 67 61 69 6e 73 74 20 69 74 path against it
6db0: 65 6d 2d 70 61 74 74 73 2c 20 0a 20 20 20 20 20 em-patts, .
6dc0: 3b 3b 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 74 ;;. ((not (t
6dd0: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
6de0: 70 61 74 74 73 20 28 74 65 73 74 73 3a 74 65 73 patts (tests:tes
6df0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
6e00: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 ame test-record)
6e10: 20 69 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 item-path requi
6e20: 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 red: required-te
6e30: 73 74 73 29 29 20 3b 3b 20 54 68 69 73 20 74 65 sts)) ;; This te
6e40: 73 74 2f 69 74 65 6d 70 61 74 68 20 69 73 20 6e st/itempath is n
6e50: 6f 74 20 74 6f 20 62 65 20 72 75 6e 0a 20 20 20 ot to be run.
6e60: 20 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 ;; else the r
6e70: 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 6d un is stuck, tem
6e80: 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 6d porarily or perm
6e90: 61 6e 65 6e 74 6c 79 0a 20 20 20 20 20 20 3b 3b anently. ;;
6ea0: 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 63 but should chec
6eb0: 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 74 k if it is due t
6ec0: 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 o lack of resour
6ed0: 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 69 ces vs. prerequi
6ee0: 73 69 74 65 73 0a 20 20 20 20 20 20 28 64 65 62 sites. (deb
6ef0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
6f00: 22 53 6b 69 70 70 69 6e 67 20 22 20 28 74 65 73 "Skipping " (tes
6f10: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
6f20: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
6f30: 65 63 6f 72 64 29 20 22 20 22 20 69 74 65 6d 2d ecord) " " item-
6f40: 70 61 74 68 20 22 20 61 73 20 69 74 20 64 6f 65 path " as it doe
6f50: 73 6e 27 74 20 6d 61 74 63 68 20 22 20 74 65 73 sn't match " tes
6f60: 74 2d 70 61 74 74 73 29 0a 20 20 20 20 20 20 28 t-patts). (
6f70: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
6f80: 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 l? tal))(not (nu
6f90: 6c 6c 3f 20 72 65 67 29 29 29 0a 09 20 20 28 6c ll? reg))).. (l
6fa0: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
6fb0: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg
6fc0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
6fd0: 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ...(runs:queue-n
6fe0: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
6ff0: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
7000: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
7010: 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 xt-reg tal reg r
7020: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
7030: 09 72 65 72 75 6e 73 29 0a 09 20 20 23 66 29 29 .reruns).. #f))
7040: 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 52 . . ;; R
7050: 65 67 69 73 74 65 72 20 74 65 73 74 73 20 0a 20 egister tests .
7060: 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 28 6e 6f ;;. ((no
7070: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
7080: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
7090: 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 egistry (runs:ma
70a0: 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d ke-full-test-nam
70b0: 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d e test-name item
70c0: 2d 70 61 74 68 29 20 23 66 29 29 0a 20 20 20 20 -path) #f)).
70d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
70e0: 6e 66 6f 20 34 20 22 50 72 65 2d 72 65 67 69 73 nfo 4 "Pre-regis
70f0: 74 65 72 69 6e 67 20 74 65 73 74 20 22 20 74 65 tering test " te
7100: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
7110: 2d 70 61 74 68 20 22 20 74 6f 20 63 72 65 61 74 -path " to creat
7120: 65 20 70 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 e placeholder" )
7130: 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
7140: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
7150: 20 27 66 73 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 'fs) ;; no poin
7160: 74 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 72 65 t in parallel re
7170: 67 69 73 74 72 61 74 69 6f 6e 20 69 66 20 75 73 gistration if us
7180: 65 20 66 73 0a 09 20 20 28 62 65 67 69 6e 0a 09 e fs.. (begin..
7190: 20 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 (cdb:tests-r
71a0: 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 egister-test *ru
71b0: 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 nremote* run-id
71c0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
71d0: 61 74 68 29 0a 09 20 20 20 20 28 68 61 73 68 2d ath).. (hash-
71e0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
71f0: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m
7200: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
7210: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
7220: 6d 2d 70 61 74 68 29 20 27 64 6f 6e 65 29 29 0a m-path) 'done)).
7230: 09 20 20 28 6c 65 74 20 28 28 74 68 20 28 6d 61 . (let ((th (ma
7240: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
7250: 61 20 28 29 0a 09 09 09 09 20 20 20 28 6d 75 74 a ()..... (mut
7260: 65 78 2d 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 ex-lock! registr
7270: 79 2d 6d 75 74 65 78 29 0a 09 09 09 09 20 20 20 y-mutex).....
7280: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
7290: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
72a0: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
72b0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
72c0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 73 me item-path) 's
72d0: 74 61 72 74 29 0a 09 09 09 09 20 20 20 28 6d 75 tart)..... (mu
72e0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 tex-unlock! regi
72f0: 73 74 72 79 2d 6d 75 74 65 78 29 0a 09 09 09 09 stry-mutex).....
7300: 20 20 20 3b 3b 20 49 66 20 68 61 76 65 6e 27 74 ;; If haven't
7310: 20 64 6f 6e 65 20 69 74 20 62 65 66 6f 72 65 20 done it before
7320: 72 65 67 69 73 74 65 72 20 61 20 74 6f 70 20 6c register a top l
7330: 65 76 65 6c 20 74 65 73 74 20 69 66 20 74 68 69 evel test if thi
7340: 73 20 69 73 20 61 6e 20 69 74 65 6d 69 7a 65 64 s is an itemized
7350: 20 74 65 73 74 0a 09 09 09 09 20 20 20 28 69 66 test..... (if
7360: 20 28 6e 6f 74 20 28 65 71 3f 20 28 68 61 73 68 (not (eq? (hash
7370: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7380: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 lt test-registry
7390: 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c (runs:make-full
73a0: 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d -test-name test-
73b0: 6e 61 6d 65 20 22 22 29 20 23 66 29 20 27 64 6f name "") #f) 'do
73c0: 6e 65 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 ne)).....
73d0: 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 (cdb:tests-regis
73e0: 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 65 6d ter-test *runrem
73f0: 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 74 ote* run-id test
7400: 2d 6e 61 6d 65 20 22 22 29 29 0a 09 09 09 09 20 -name "")).....
7410: 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 (cdb:tests-reg
7420: 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 ister-test *runr
7430: 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 emote* run-id te
7440: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
7450: 68 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 h)..... (mutex
7460: 2d 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 79 2d -lock! registry-
7470: 6d 75 74 65 78 29 0a 09 09 09 09 20 20 20 28 68 mutex)..... (h
7480: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
7490: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 est-registry (ru
74a0: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
74b0: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name
74c0: 20 69 74 65 6d 2d 70 61 74 68 29 20 27 64 6f 6e item-path) 'don
74d0: 65 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 e)..... (mutex
74e0: 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 73 74 72 -unlock! registr
74f0: 79 2d 6d 75 74 65 78 29 29 0a 09 09 09 09 20 28 y-mutex))..... (
7500: 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 conc test-name "
7510: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 /" item-path))))
7520: 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 .. (thread-st
7530: 61 72 74 21 20 74 68 29 29 29 0a 20 20 20 20 20 art! th))).
7540: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
7550: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
7560: 2d 63 6f 75 6e 74 29 20 20 20 3b 3b 20 44 45 4c -count) ;; DEL
7570: 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c AY TWEAKER (stil
7580: 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 20 l needed?).
7590: 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f (if (and (null?
75a0: 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 29 tal)(null? reg)
75b0: 29 0a 09 20 20 28 6c 69 73 74 20 68 65 64 20 74 ).. (list hed t
75c0: 61 6c 20 28 61 70 70 65 6e 64 20 72 65 67 20 28 al (append reg (
75d0: 6c 69 73 74 20 68 65 64 29 29 20 72 65 72 75 6e list hed)) rerun
75e0: 73 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e s).. (list (run
75f0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 s:queue-next-hed
7600: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
7610: 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 regfull)...(runs
7620: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
7630: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
7640: 65 67 66 75 6c 6c 29 0a 09 09 3b 3b 20 4e 42 2f egfull)...;; NB/
7650: 2f 20 48 65 72 65 20 77 65 20 61 72 65 20 62 75 / Here we are bu
7660: 69 6c 64 69 6e 67 20 72 65 67 20 61 73 20 77 65 ilding reg as we
7670: 20 72 65 67 69 73 74 65 72 20 74 65 73 74 73 0a register tests.
7680: 09 09 3b 3b 20 69 66 20 72 65 67 66 75 6c 6c 20 ..;; if regfull
7690: 77 65 20 6d 75 73 74 20 70 6f 70 20 74 68 65 20 we must pop the
76a0: 66 72 6f 6e 74 20 69 74 65 6d 20 6f 66 66 20 72 front item off r
76b0: 65 67 0a 09 09 28 69 66 20 72 65 67 66 75 6c 6c eg...(if regfull
76c0: 0a 09 09 20 20 20 20 28 61 70 70 65 6e 64 20 28 ... (append (
76d0: 63 64 72 20 72 65 67 29 20 28 6c 69 73 74 20 68 cdr reg) (list h
76e0: 65 64 29 29 0a 09 09 20 20 20 20 28 61 70 70 65 ed))... (appe
76f0: 6e 64 20 72 65 67 20 28 6c 69 73 74 20 68 65 64 nd reg (list hed
7700: 29 29 29 0a 09 09 72 65 72 75 6e 73 29 29 29 0a )))...reruns))).
7710: 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 41 74 . ;; At
7720: 20 74 68 69 73 20 70 6f 69 6e 74 20 68 65 64 20 this point hed
7730: 74 65 73 74 20 72 65 67 69 73 74 72 61 74 69 6f test registratio
7740: 6e 20 6d 75 73 74 20 62 65 20 63 6f 6d 70 6c 65 n must be comple
7750: 74 65 64 2e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 ted.. ;;.
7760: 20 20 28 28 65 71 3f 20 28 68 61 73 68 2d 74 61 ((eq? (hash-ta
7770: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7780: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
7790: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
77a0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
77b0: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 e item-path) #f)
77c0: 0a 09 20 20 20 27 73 74 61 72 74 29 0a 20 20 20 .. 'start).
77d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
77e0: 69 6e 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 info 0 "Waiting
77f0: 6f 6e 20 74 65 73 74 20 72 65 67 69 73 74 72 61 on test registra
7800: 74 69 6f 6e 28 73 29 3a 20 22 0a 09 09 09 28 73 tion(s): "....(s
7810: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7820: 65 20 0a 09 09 09 20 28 66 69 6c 74 65 72 20 28 e .... (filter (
7830: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 lambda (x).....
7840: 20 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 (eq? (hash-tab
7850: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
7860: 65 73 74 2d 72 65 67 69 73 74 72 79 20 78 20 23 est-registry x #
7870: 66 29 20 27 73 74 61 72 74 29 29 0a 09 09 09 09 f) 'start)).....
7880: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
7890: 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 29 s test-registry)
78a0: 29 0a 09 09 09 20 22 2c 20 22 29 29 0a 20 20 20 ).... ", ")).
78b0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
78c0: 21 20 30 2e 31 29 0a 20 20 20 20 20 20 28 6c 69 ! 0.1). (li
78d0: 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 st hed tal reg r
78e0: 65 72 75 6e 73 29 29 0a 20 20 20 20 20 0a 20 20 eruns)). .
78f0: 20 20 20 3b 3b 20 49 66 20 6e 6f 20 72 65 73 6f ;; If no reso
7900: 75 72 63 65 73 20 61 72 65 20 61 76 61 69 6c 61 urces are availa
7910: 62 6c 65 20 6a 75 73 74 20 6b 69 6c 6c 20 74 69 ble just kill ti
7920: 6d 65 20 61 6e 64 20 6c 6f 6f 70 20 61 67 61 69 me and loop agai
7930: 6e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 n. ;;. (
7940: 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 (not have-resour
7950: 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 ces) ;; simply t
7960: 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 ry again after w
7970: 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a aiting a second.
7980: 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a (if (runs:
7990: 6c 6f 77 6e 6f 69 73 65 20 22 6e 6f 20 72 65 73 lownoise "no res
79a0: 6f 75 72 63 65 73 22 20 36 30 29 0a 09 20 20 28 ources" 60).. (
79b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
79c0: 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 73 1 "no resources
79d0: 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 to run new test
79e0: 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 s, waiting ...")
79f0: 29 0a 20 20 20 20 20 20 3b 3b 20 48 61 76 65 20 ). ;; Have
7a00: 67 6f 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 6f gone back and fo
7a10: 72 74 68 20 6f 6e 20 74 68 69 73 20 62 75 74 20 rth on this but
7a20: 64 62 20 73 74 61 72 76 61 74 69 6f 6e 20 69 73 db starvation is
7a30: 20 61 6e 20 69 73 73 75 65 2e 0a 20 20 20 20 20 an issue..
7a40: 20 3b 3b 20 77 61 69 74 20 6f 6e 65 20 73 65 63 ;; wait one sec
7a50: 6f 6e 64 20 62 65 66 6f 72 65 20 6c 6f 6f 6b 69 ond before looki
7a60: 6e 67 20 61 67 61 69 6e 20 74 6f 20 72 75 6e 20 ng again to run
7a70: 6a 6f 62 73 2e 0a 20 20 20 20 20 20 28 74 68 72 jobs.. (thr
7a80: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 20 ead-sleep! 1).
7a90: 20 20 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 ;; could hav
7aa0: 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 e done hed tal h
7ab0: 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 61 ere but doing ca
7ac0: 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 r/cdr of newtal
7ad0: 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 0a to rotate tests.
7ae0: 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 (list (car
7af0: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
7b00: 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 tal) reg reruns)
7b10: 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 ). . ;;
7b20: 54 68 69 73 20 69 73 20 74 68 65 20 66 69 6e 61 This is the fina
7b30: 6c 20 73 74 61 67 65 2c 20 65 76 65 72 79 74 68 l stage, everyth
7b40: 69 6e 67 20 69 73 20 69 6e 20 70 6c 61 63 65 20 ing is in place
7b50: 73 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 so launch the te
7b60: 73 74 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 st. ;;.
7b70: 28 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 ((and have-resou
7b80: 72 63 65 73 0a 09 20 20 20 28 6f 72 20 28 6e 75 rces.. (or (nu
7b90: 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ll? prereqs-not-
7ba0: 6d 65 74 29 0a 09 20 20 20 20 20 20 20 28 61 6e met).. (an
7bb0: 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 d (eq? testmode
7bc0: 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 20 20 20 'toplevel)...
7bd0: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
7be0: 6c 65 74 65 64 29 29 29 29 0a 20 20 20 20 20 20 leted)))).
7bf0: 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 (run:test run-id
7c00: 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c run-info keyval
7c10: 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 s runname test-r
7c20: 65 63 6f 72 64 20 66 6c 61 67 73 20 23 66 20 74 ecord flags #f t
7c30: 65 73 74 2d 72 65 67 69 73 74 72 79 20 61 6c 6c est-registry all
7c40: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 -tests-registry)
7c50: 0a 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
7c60: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
7c70: 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 istry (runs:make
7c80: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name
7c90: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
7ca0: 61 74 68 29 20 27 72 75 6e 6e 69 6e 67 29 0a 20 ath) 'running).
7cb0: 20 20 20 20 20 28 72 75 6e 73 3a 73 68 72 69 6e (runs:shrin
7cc0: 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 k-can-run-more-t
7cd0: 65 73 74 73 2d 63 6f 75 6e 74 29 20 20 3b 3b 20 ests-count) ;;
7ce0: 44 45 4c 41 59 20 54 57 45 41 4b 45 52 20 28 73 DELAY TWEAKER (s
7cf0: 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 till needed?).
7d00: 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 ;; (thread-s
7d10: 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 leep! *global-de
7d20: 6c 74 61 2a 29 0a 20 20 20 20 20 20 28 69 66 20 lta*). (if
7d30: 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (or (not (null?
7d40: 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f tal))(not (null?
7d50: 20 72 65 67 29 29 29 0a 09 20 20 28 6c 69 73 74 reg))).. (list
7d60: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
7d70: 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t-hed tal reg re
7d80: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
7d90: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
7da0: 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 65 67 -tal tal reg reg
7db0: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 len regfull)...(
7dc0: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
7dd0: 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c reg tal reg regl
7de0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 72 65 en regfull)...re
7df0: 72 75 6e 73 29 0a 09 20 20 23 66 29 29 0a 20 20 runs).. #f)).
7e00: 20 20 20 0a 20 20 20 20 20 3b 3b 20 6d 75 73 74 . ;; must
7e10: 20 62 65 20 77 65 20 68 61 76 65 20 75 6e 6d 65 be we have unme
7e20: 74 20 70 72 65 72 65 71 75 69 73 69 74 65 73 0a t prerequisites.
7e30: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 65 6c ;;. (el
7e40: 73 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a se. (debug:
7e50: 70 72 69 6e 74 20 34 20 22 46 41 49 4c 53 3a 20 print 4 "FAILS:
7e60: 22 20 66 61 69 6c 73 29 0a 20 20 20 20 20 20 3b " fails). ;
7e70: 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 ; If one or more
7e80: 20 6f 66 20 74 68 65 20 70 72 65 72 65 71 73 2d of the prereqs-
7e90: 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 41 49 4c not-met are FAIL
7ea0: 20 74 68 65 6e 20 77 65 20 63 61 6e 20 69 73 73 then we can iss
7eb0: 75 65 0a 20 20 20 20 20 20 3b 3b 20 61 20 6d 65 ue. ;; a me
7ec0: 73 73 61 67 65 20 61 6e 64 20 64 72 6f 70 20 68 ssage and drop h
7ed0: 65 64 20 66 72 6f 6d 20 74 68 65 20 69 74 65 6d ed from the item
7ee0: 73 20 74 6f 20 62 65 20 70 72 6f 63 65 73 73 65 s to be processe
7ef0: 64 2e 0a 0a 20 20 20 20 20 20 28 69 66 20 28 6e d... (if (n
7f00: 6f 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 ot (null? prereq
7f10: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 20 28 s-not-met)).. (
7f20: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7f30: 20 31 20 22 77 61 69 74 69 6e 67 20 6f 6e 20 74 1 "waiting on t
7f40: 65 73 74 73 3b 20 22 20 28 73 74 72 69 6e 67 2d ests; " (string-
7f50: 69 6e 74 65 72 73 70 65 72 73 65 20 70 72 65 72 intersperse prer
7f60: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 22 2c 20 22 eqs-not-met ", "
7f70: 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 ))). .
7f80: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (if (null? fail
7f90: 73 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 s).. (begin..
7fa0: 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 ;; couldn't ru
7fb0: 6e 2c 20 74 61 6b 65 20 61 20 62 72 65 61 74 68 n, take a breath
7fc0: 65 72 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 er.. (debug:p
7fd0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 rint-info 0 "Wai
7fe0: 74 69 6e 67 20 66 6f 72 20 6d 6f 72 65 20 77 6f ting for more wo
7ff0: 72 6b 20 74 6f 20 64 6f 2e 2e 2e 22 29 0a 09 20 rk to do...")..
8000: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
8010: 21 20 31 29 0a 09 20 20 20 20 28 6c 69 73 74 20 ! 1).. (list
8020: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
8030: 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 newtal) reg rer
8040: 75 6e 73 29 29 0a 09 20 20 3b 3b 20 74 68 65 20 uns)).. ;; the
8050: 77 61 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 73 waiton is FAIL s
8060: 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 72 o no point in tr
8070: 79 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 20 ying to run hed
8080: 65 76 65 72 20 61 67 61 69 6e 0a 09 20 20 28 69 ever again.. (i
8090: 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
80a0: 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 6c ? reg))(not (nul
80b0: 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 20 20 l? tal)))..
80c0: 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 65 (if (vector? he
80d0: 64 29 0a 09 09 20 20 28 62 65 67 69 6e 20 0a 09 d)... (begin ..
80e0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
80f0: 74 20 31 20 22 57 41 52 4e 3a 20 44 72 6f 70 70 t 1 "WARN: Dropp
8100: 69 6e 67 20 74 65 73 74 20 22 20 28 64 62 3a 74 ing test " (db:t
8110: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
8120: 20 68 65 64 29 20 22 2f 22 20 28 64 62 3a 74 65 hed) "/" (db:te
8130: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
8140: 20 68 65 64 29 0a 09 09 09 09 20 22 20 66 72 6f hed)..... " fro
8150: 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 m the launch lis
8160: 74 20 61 73 20 69 74 20 68 61 73 20 70 72 65 72 t as it has prer
8170: 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 72 equistes that ar
8180: 65 20 46 41 49 4c 22 29 0a 09 09 20 20 20 20 28 e FAIL")... (
8190: 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d runs:shrink-can-
81a0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
81b0: 6f 75 6e 74 29 20 3b 3b 20 44 45 4c 41 59 20 54 ount) ;; DELAY T
81c0: 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 WEAKER (still ne
81d0: 65 64 65 64 3f 29 0a 09 09 20 20 20 20 3b 3b 20 eded?)... ;;
81e0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a (thread-sleep! *
81f0: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 global-delta*)..
8200: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
8210: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
8220: 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 try (runs:make-f
8230: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
8240: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
8250: 68 29 20 27 72 65 6d 6f 76 65 64 29 0a 09 09 20 h) 'removed)...
8260: 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 (list (runs:q
8270: 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 ueue-next-hed ta
8280: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
8290: 66 75 6c 6c 29 0a 09 09 09 20 20 28 72 75 6e 73 full).... (runs
82a0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
82b0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
82c0: 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 72 75 egfull).... (ru
82d0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 ns:queue-next-re
82e0: 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e g tal reg reglen
82f0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 regfull).... (
8300: 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 29 cons hed reruns)
8310: 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ))... (begin...
8320: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8330: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 73 0 "WARNING: Tes
8340: 74 20 6e 6f 74 20 70 72 6f 63 65 73 73 65 64 20 t not processed
8350: 63 6f 72 72 65 63 74 6c 79 2e 20 43 6f 75 6c 64 correctly. Could
8360: 20 62 65 20 61 20 72 61 63 65 20 63 6f 6e 64 69 be a race condi
8370: 74 69 6f 6e 20 69 6e 20 79 6f 75 72 20 74 65 73 tion in your tes
8380: 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e t implementation
8390: 3f 20 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 ? Dropping test
83a0: 22 20 68 65 64 29 20 3b 3b 20 20 22 20 61 73 20 " hed) ;; " as
83b0: 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 it has prerequis
83c0: 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 tes that are FAI
83d0: 4c 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 69 73 L. (NOTE: hed is
83e0: 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 22 29 not a vector)")
83f0: 0a 09 09 20 20 20 20 28 72 75 6e 73 3a 73 68 72 ... (runs:shr
8400: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
8410: 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 3b 3b -tests-count) ;;
8420: 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 20 28 DELAY TWEAKER (
8430: 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 09 still needed?)..
8440: 09 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 68 65 . ;; (list he
8450: 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 d tal reg reruns
8460: 29 0a 09 09 20 20 20 20 28 6c 69 73 74 20 28 63 )... (list (c
8470: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
8480: 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e ewtal) reg rerun
8490: 73 29 0a 09 09 20 20 20 20 29 29 29 29 29 29 29 s)... )))))))
84a0: 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 )..;; test-recor
84b0: 64 73 20 69 73 20 61 20 68 61 73 68 20 74 61 62 ds is a hash tab
84c0: 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d le testname:item
84d0: 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 _path => vector
84e0: 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 < testname testc
84f0: 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 onfig waitons pr
8500: 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 iority items-inf
8510: 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 o ... >.(define
8520: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d (runs:run-tests-
8530: 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e queue run-id run
8540: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
8550: 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 67 73 20 s keyvals flags
8560: 74 65 73 74 2d 70 61 74 74 73 20 72 65 71 75 69 test-patts requi
8570: 72 65 64 2d 74 65 73 74 73 20 72 65 67 6c 65 6e red-tests reglen
8580: 2d 69 6e 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 -in all-tests-re
8590: 67 69 73 74 72 79 29 0a 20 20 3b 3b 20 41 74 20 gistry). ;; At
85a0: 74 68 69 73 20 70 6f 69 6e 74 20 74 68 65 20 6c this point the l
85b0: 69 73 74 20 6f 66 20 70 61 72 65 6e 74 20 74 65 ist of parent te
85c0: 73 74 73 20 69 73 20 65 78 70 61 6e 64 65 64 20 sts is expanded
85d0: 0a 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c . ;; NB// Shoul
85e0: 64 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 68 d expand items h
85f0: 65 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 ere and then ins
8600: 65 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 6e ert into the run
8610: 20 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 67 queue.. (debug
8620: 3a 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d 72 :print 5 "test-r
8630: 65 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d 72 ecords: " test-r
8640: 65 63 6f 72 64 73 20 22 2c 20 66 6c 61 67 73 3a ecords ", flags:
8650: 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e " (hash-table->
8660: 61 6c 69 73 74 20 66 6c 61 67 73 29 29 0a 20 20 alist flags)).
8670: 28 6c 65 74 20 28 28 72 75 6e 2d 69 6e 66 6f 20 (let ((run-info
8680: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 (cd
8690: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
86a0: 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 23 66 20 get-run-info #f
86b0: 72 75 6e 2d 69 64 29 29 0a 09 28 74 65 73 74 73 run-id))..(tests
86c0: 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 20 20 -info
86d0: 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (mt:get-tests-f
86e0: 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 23 66 or-run run-id #f
86f0: 20 27 28 29 20 27 28 29 29 29 20 3b 3b 20 20 71 '() '())) ;; q
8700: 72 79 76 61 6c 73 3a 20 22 69 64 2c 74 65 73 74 ryvals: "id,test
8710: 6e 61 6d 65 2c 69 74 65 6d 5f 70 61 74 68 22 29 name,item_path")
8720: 29 0a 09 28 73 6f 72 74 65 64 2d 74 65 73 74 2d )..(sorted-test-
8730: 6e 61 6d 65 73 20 20 20 20 20 28 74 65 73 74 73 names (tests
8740: 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 :sort-by-priorit
8750: 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 y-and-waiton tes
8760: 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 74 65 t-records))..(te
8770: 73 74 2d 72 65 67 69 73 74 72 79 20 20 20 20 20 st-registry
8780: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
8790: 61 62 6c 65 29 29 0a 09 28 72 65 67 69 73 74 72 able))..(registr
87a0: 79 2d 6d 75 74 65 78 20 20 20 20 20 20 20 20 28 y-mutex (
87b0: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 28 6e make-mutex))..(n
87c0: 75 6d 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 um-retries
87d0: 20 20 20 20 20 30 29 0a 09 28 6d 61 78 2d 72 65 0)..(max-re
87e0: 74 72 69 65 73 20 20 20 20 20 20 20 20 20 20 20 tries
87f0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a (config-lookup *
8800: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
8810: 70 22 20 22 6d 61 78 72 65 74 72 69 65 73 22 29 p" "maxretries")
8820: 29 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 )..(max-concurre
8830: 6e 74 2d 6a 6f 62 73 20 20 20 28 6c 65 74 20 28 nt-jobs (let (
8840: 28 6d 63 6a 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (mcj (config-loo
8850: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
8860: 22 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 "setup" "max
8870: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
8880: 22 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 61 ")))..... (if (a
8890: 6e 64 20 6d 63 6a 20 28 73 74 72 69 6e 67 2d 3e nd mcj (string->
88a0: 6e 75 6d 62 65 72 20 6d 63 6a 29 29 0a 09 09 09 number mcj))....
88b0: 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e . (string->n
88c0: 75 6d 62 65 72 20 6d 63 6a 29 0a 09 09 09 09 20 umber mcj).....
88d0: 20 20 20 20 31 29 29 29 20 3b 3b 20 6c 65 6e 67 1))) ;; leng
88e0: 74 68 20 6f 66 20 74 68 65 20 72 65 67 69 73 74 th of the regist
88f0: 65 72 20 71 75 65 75 65 20 61 68 65 61 64 0a 09 er queue ahead..
8900: 28 72 65 67 6c 65 6e 20 20 20 20 20 20 20 20 20 (reglen
8910: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 (if (numb
8920: 65 72 3f 20 72 65 67 6c 65 6e 2d 69 6e 29 20 72 er? reglen-in) r
8930: 65 67 6c 65 6e 2d 69 6e 20 31 29 29 29 0a 0a 20 eglen-in 1)))..
8940: 20 20 20 3b 3b 20 49 6e 69 74 69 61 6c 69 7a 65 ;; Initialize
8950: 20 74 68 65 20 74 65 73 74 2d 72 65 67 69 73 74 the test-regist
8960: 65 72 79 20 68 61 73 68 20 77 69 74 68 20 74 65 ery hash with te
8970: 73 74 73 20 74 68 61 74 20 61 6c 72 65 61 64 79 sts that already
8980: 20 68 61 76 65 20 61 20 72 65 63 6f 72 64 0a 20 have a record.
8990: 20 20 20 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 ;; convert st
89a0: 61 74 65 20 74 6f 20 73 79 6d 62 6f 6c 20 61 6e ate to symbol an
89b0: 64 20 75 73 65 20 74 68 61 74 20 61 73 20 74 68 d use that as th
89c0: 65 20 68 61 73 68 20 76 61 6c 75 65 0a 20 20 20 e hash value.
89d0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
89e0: 64 61 20 28 74 72 65 63 29 0a 09 09 28 6c 65 74 da (trec)...(let
89f0: 20 28 28 69 64 20 28 64 62 3a 74 65 73 74 2d 67 ((id (db:test-g
8a00: 65 74 2d 69 64 20 20 20 20 20 20 20 20 74 72 65 et-id tre
8a10: 63 29 29 0a 09 09 20 20 20 20 20 20 28 74 6e 20 c))... (tn
8a20: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
8a30: 74 6e 61 6d 65 20 20 74 72 65 63 29 29 0a 09 09 tname trec))...
8a40: 20 20 20 20 20 20 28 69 70 20 28 64 62 3a 74 65 (ip (db:te
8a50: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
8a60: 20 74 72 65 63 29 29 0a 09 09 20 20 20 20 20 20 trec))...
8a70: 28 73 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (st (db:test-get
8a80: 2d 73 74 61 74 65 20 20 20 20 20 74 72 65 63 29 -state trec)
8a90: 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 ))... (if (not
8aa0: 28 65 71 75 61 6c 3f 20 73 74 20 22 44 45 4c 45 (equal? st "DELE
8ab0: 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 20 28 TED"))... (
8ac0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8ad0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
8ae0: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
8af0: 73 74 2d 6e 61 6d 65 20 74 6e 20 69 70 29 20 28 st-name tn ip) (
8b00: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 string->symbol s
8b10: 74 29 29 29 29 29 0a 09 20 20 20 20 20 20 74 65 t))))).. te
8b20: 73 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 28 73 sts-info). (s
8b30: 65 74 21 20 6d 61 78 2d 72 65 74 72 69 65 73 20 et! max-retries
8b40: 28 69 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 (if (and max-ret
8b50: 72 69 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 ries (string->nu
8b60: 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 mber max-retries
8b70: 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ))(string->numbe
8b80: 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 20 31 r max-retries) 1
8b90: 30 30 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 6c 00)).. (let l
8ba0: 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 20 oop ((hed
8bb0: 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 (car sorted-te
8bc0: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 st-names))..
8bd0: 20 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 (tal
8be0: 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (cdr sorted-test
8bf0: 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 20 -names))..
8c00: 20 28 72 65 67 20 20 20 20 20 20 20 20 20 27 28 (reg '(
8c10: 29 29 20 3b 3b 20 72 65 67 69 73 74 65 72 65 64 )) ;; registered
8c20: 2c 20 70 75 74 20 74 68 65 73 65 20 61 74 20 74 , put these at t
8c30: 68 65 20 68 65 61 64 20 6f 66 20 74 61 6c 20 0a he head of tal .
8c40: 09 20 20 20 20 20 20 20 28 72 65 72 75 6e 73 20 . (reruns
8c50: 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 20 '())).
8c60: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
8c70: 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 67 3a reruns))(debug:
8c80: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 65 print-info 4 "re
8c90: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a runs=" reruns)).
8ca0: 0a 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 . ;; (print
8cb0: 20 22 54 6f 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 "Top of loop, h
8cc0: 65 64 3d 22 20 68 65 64 20 22 2c 20 74 61 6c 3d ed=" hed ", tal=
8cd0: 22 20 74 61 6c 20 22 20 2c 72 65 72 75 6e 73 3d " tal " ,reruns=
8ce0: 22 20 72 65 72 75 6e 73 29 0a 20 20 20 20 20 20 " reruns).
8cf0: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 63 (let* ((test-rec
8d00: 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ord (hash-table-
8d10: 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
8d20: 20 68 65 64 29 29 0a 09 20 20 20 20 20 28 74 65 hed)).. (te
8d30: 73 74 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 73 st-name (tests
8d40: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
8d50: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
8d60: 6f 72 64 29 29 0a 09 20 20 20 20 20 28 74 63 6f ord)).. (tco
8d70: 6e 66 69 67 20 20 20 20 20 28 74 65 73 74 73 3a nfig (tests:
8d80: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
8d90: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 stconfig test-re
8da0: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 6a 6f cord)).. (jo
8db0: 62 67 72 6f 75 70 20 20 20 20 28 63 6f 6e 66 69 bgroup (confi
8dc0: 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 g-lookup tconfig
8dd0: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
8de0: 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 20 20 "jobgroup"))..
8df0: 20 20 20 28 74 65 73 74 6d 6f 64 65 20 20 20 20 (testmode
8e00: 28 6c 65 74 20 28 28 6d 20 28 63 6f 6e 66 69 67 (let ((m (config
8e10: 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 -lookup tconfig
8e20: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
8e30: 6d 6f 64 65 22 29 29 29 0a 09 09 09 20 20 20 20 mode")))....
8e40: 28 69 66 20 6d 20 28 73 74 72 69 6e 67 2d 3e 73 (if m (string->s
8e50: 79 6d 62 6f 6c 20 6d 29 20 27 6e 6f 72 6d 61 6c ymbol m) 'normal
8e60: 29 29 29 0a 09 20 20 20 20 20 28 77 61 69 74 6f ))).. (waito
8e70: 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 ns (tests:te
8e80: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
8e90: 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f ons test-reco
8ea0: 72 64 29 29 0a 09 20 20 20 20 20 28 70 72 69 6f rd)).. (prio
8eb0: 72 69 74 79 20 20 20 20 28 74 65 73 74 73 3a 74 rity (tests:t
8ec0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 estqueue-get-pri
8ed0: 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 63 ority test-rec
8ee0: 6f 72 64 29 29 0a 09 20 20 20 20 20 28 69 74 65 ord)).. (ite
8ef0: 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 3a mdat (tests:
8f00: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
8f10: 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 emdat test-re
8f20: 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 cord)) ;; itemda
8f30: 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 69 6e t can be a strin
8f40: 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 20 g, list or #f..
8f50: 20 20 20 20 28 69 74 65 6d 73 20 20 20 20 20 20 (items
8f60: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
8f70: 65 2d 67 65 74 2d 69 74 65 6d 73 20 20 20 20 20 e-get-items
8f80: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
8f90: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
8fa0: 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 (item-list->pa
8fb0: 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 20 20 th itemdat))..
8fc0: 20 20 20 28 74 66 75 6c 6c 6e 61 6d 65 20 20 20 (tfullname
8fd0: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
8fe0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
8ff0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a ame item-path)).
9000: 09 20 20 20 20 20 28 6e 65 77 74 61 6c 20 20 20 . (newtal
9010: 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 (append tal (
9020: 6c 69 73 74 20 68 65 64 29 29 29 0a 09 20 20 20 list hed)))..
9030: 20 20 28 72 65 67 66 75 6c 6c 20 20 20 20 20 28 (regfull (
9040: 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 67 29 20 >= (length reg)
9050: 72 65 67 6c 65 6e 29 29 29 0a 0a 09 3b 3b 20 45 reglen)))...;; E
9060: 6e 73 75 72 65 20 61 6c 6c 20 74 6f 70 20 6c 65 nsure all top le
9070: 76 65 6c 20 74 65 73 74 73 20 67 65 74 20 72 65 vel tests get re
9080: 67 69 73 74 65 72 65 64 2e 20 54 68 69 73 20 77 gistered. This w
9090: 61 79 20 74 68 65 79 20 73 68 6f 77 20 75 70 20 ay they show up
90a0: 61 73 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 as "NOT_STARTED"
90b0: 20 6f 6e 20 74 68 65 20 64 61 73 68 62 6f 61 72 on the dashboar
90c0: 64 0a 09 3b 3b 20 61 6e 64 20 69 74 20 69 73 20 d..;; and it is
90d0: 63 6c 65 61 72 20 74 68 65 79 20 2a 73 68 6f 75 clear they *shou
90e0: 6c 64 2a 20 68 61 76 65 20 72 75 6e 20 62 75 74 ld* have run but
90f0: 20 64 69 64 20 6e 6f 74 2e 0a 09 28 69 66 20 28 did not...(if (
9100: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
9110: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
9120: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
9130: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
9140: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 ame test-name ""
9150: 29 20 23 66 29 29 0a 09 20 20 20 20 28 62 65 67 ) #f)).. (beg
9160: 69 6e 0a 09 20 20 20 20 20 20 28 63 64 62 3a 74 in.. (cdb:t
9170: 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 ests-register-te
9180: 73 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 st *runremote* r
9190: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
91a0: 22 22 29 0a 09 20 20 20 20 20 20 28 68 61 73 68 "").. (hash
91b0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
91c0: 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a -registry (runs:
91d0: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
91e0: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 ame test-name ""
91f0: 29 20 27 64 6f 6e 65 29 29 29 0a 09 0a 09 3b 3b ) 'done)))....;;
9200: 20 46 61 73 74 20 73 6b 69 70 20 6f 66 20 74 65 Fast skip of te
9210: 73 74 73 20 74 68 61 74 20 61 72 65 20 61 6c 72 sts that are alr
9220: 65 61 64 79 20 22 43 4f 4d 50 4c 45 54 45 44 22 eady "COMPLETED"
9230: 20 2d 20 4e 4f 21 20 43 61 6e 6e 6f 74 20 64 6f - NO! Cannot do
9240: 20 74 68 61 74 20 61 73 20 74 68 65 20 69 74 65 that as the ite
9250: 6d 73 20 6d 61 79 20 6e 6f 74 20 68 61 76 65 20 ms may not have
9260: 62 65 65 6e 20 65 78 70 61 6e 64 65 64 20 79 65 been expanded ye
9270: 74 20 3a 28 0a 09 3b 3b 0a 09 28 69 66 20 28 6d t :(..;;..(if (m
9280: 65 6d 62 65 72 20 28 68 61 73 68 2d 74 61 62 6c ember (hash-tabl
9290: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
92a0: 73 74 2d 72 65 67 69 73 74 72 79 20 74 66 75 6c st-registry tful
92b0: 6c 6e 61 6d 65 20 23 66 29 20 0a 09 09 20 20 20 lname #f) ...
92c0: 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f '(DONOTRUN remo
92d0: 76 65 64 29 29 20 3b 3b 20 2a 63 6f 6d 6d 6f 6e ved)) ;; *common
92e0: 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 :cant-run-states
92f0: 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 43 4f 4d 50 -sym*) ;; '(COMP
9300: 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 41 49 LETED KILLED WAI
9310: 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e 43 4f VED UNKNOWN INCO
9320: 4d 50 4c 45 54 45 29 29 0a 09 20 20 20 20 28 62 MPLETE)).. (b
9330: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
9340: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
9350: 22 53 6b 69 70 70 69 6e 67 20 74 65 73 74 20 22 "Skipping test "
9360: 20 74 66 75 6c 6c 6e 61 6d 65 20 22 20 61 73 20 tfullname " as
9370: 69 74 20 68 61 73 20 62 65 65 6e 20 6d 61 72 6b it has been mark
9380: 65 64 20 64 6f 20 6e 6f 74 20 72 75 6e 20 64 75 ed do not run du
9390: 65 20 74 6f 20 62 65 69 6e 67 20 63 6f 6d 70 6c e to being compl
93a0: 65 74 65 64 20 6f 72 20 6e 6f 74 20 72 75 6e 6e eted or not runn
93b0: 61 62 6c 65 22 29 0a 09 20 20 20 20 20 20 28 69 able").. (i
93c0: 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
93d0: 3f 20 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 6c ? tal))(not (nul
93e0: 6c 3f 20 72 65 67 29 29 29 0a 09 09 20 20 28 6c l? reg)))... (l
93f0: 6f 6f 70 20 28 72 75 6e 73 3a 71 75 65 75 65 2d oop (runs:queue-
9400: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg
9410: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
9420: 0a 09 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d ....(runs:queue-
9430: 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 next-tal tal reg
9440: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
9450: 0a 09 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d ....(runs:queue-
9460: 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 next-reg tal reg
9470: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
9480: 0a 09 09 09 72 65 72 75 6e 73 29 29 29 29 0a 09 ....reruns))))..
9490: 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 72 . ;; (loop (car
94a0: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 tal)(cdr tal) r
94b0: 65 67 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 eg reruns))))...
94c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
94d0: 54 4f 50 20 4f 46 20 4c 4f 4f 50 20 3d 3e 20 22 TOP OF LOOP => "
94e0: 0a 09 09 20 20 20 20 20 22 74 65 73 74 2d 6e 61 ... "test-na
94f0: 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 0a me: " test-name.
9500: 09 09 20 20 20 20 20 22 5c 6e 20 20 74 65 73 74 .. "\n test
9510: 2d 72 65 63 6f 72 64 20 20 22 20 74 65 73 74 2d -record " test-
9520: 72 65 63 6f 72 64 0a 09 09 20 20 20 20 20 22 5c record... "\
9530: 6e 20 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 n hed:
9540: 22 20 68 65 64 0a 09 09 20 20 20 20 20 22 5c 6e " hed... "\n
9550: 20 20 69 74 65 6d 64 61 74 3a 20 20 20 20 20 22 itemdat: "
9560: 20 69 74 65 6d 64 61 74 0a 09 09 20 20 20 20 20 itemdat...
9570: 22 5c 6e 20 20 69 74 65 6d 73 3a 20 20 20 20 20 "\n items:
9580: 20 20 22 20 69 74 65 6d 73 0a 09 09 20 20 20 20 " items...
9590: 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a "\n item-path:
95a0: 20 20 20 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 " item-path..
95b0: 09 20 20 20 20 20 22 5c 6e 20 20 77 61 69 74 6f . "\n waito
95c0: 6e 73 3a 20 20 20 20 20 22 20 77 61 69 74 6f 6e ns: " waiton
95d0: 73 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 6e 75 s... "\n nu
95e0: 6d 2d 72 65 74 72 69 65 73 3a 20 22 20 6e 75 6d m-retries: " num
95f0: 2d 72 65 74 72 69 65 73 0a 09 09 20 20 20 20 20 -retries...
9600: 22 5c 6e 20 20 74 61 6c 3a 20 20 20 20 20 20 20 "\n tal:
9610: 20 20 22 20 74 61 6c 0a 09 09 20 20 20 20 20 22 " tal... "
9620: 5c 6e 20 20 72 65 72 75 6e 73 3a 20 20 20 20 20 \n reruns:
9630: 20 22 20 72 65 72 75 6e 73 0a 09 09 20 20 20 20 " reruns...
9640: 20 22 5c 6e 20 20 72 65 67 66 75 6c 6c 3a 20 20 "\n regfull:
9650: 20 20 20 22 20 72 65 67 66 75 6c 6c 0a 09 09 20 " regfull...
9660: 20 20 20 20 22 5c 6e 20 20 72 65 67 6c 65 6e 3a "\n reglen:
9670: 20 20 20 20 20 20 22 20 72 65 67 6c 65 6e 0a 09 " reglen..
9680: 09 20 20 20 20 20 22 5c 6e 20 20 6c 65 6e 67 74 . "\n lengt
9690: 68 20 72 65 67 3a 20 20 22 20 28 6c 65 6e 67 74 h reg: " (lengt
96a0: 68 20 72 65 67 29 0a 09 09 20 20 20 20 20 22 5c h reg)... "\
96b0: 6e 20 20 72 65 67 3a 20 20 20 20 20 20 20 20 20 n reg:
96c0: 22 20 72 65 67 29 0a 0a 09 3b 3b 20 63 68 65 63 " reg)...;; chec
96d0: 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 k for hed in wai
96e0: 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 tons => this wou
96f0: 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 ld be circular,
9700: 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 remove it and is
9710: 73 75 65 20 61 6e 0a 09 3b 3b 20 65 72 72 6f 72 sue an..;; error
9720: 0a 09 28 69 66 20 28 6d 65 6d 62 65 72 20 74 65 ..(if (member te
9730: 73 74 2d 6e 61 6d 65 20 77 61 69 74 6f 6e 73 29 st-name waitons)
9740: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
9750: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9760: 20 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 0 "ERROR: test
9770: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 " test-name " ha
9780: 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 s listed itself
9790: 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 as a waiton, ple
97a0: 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 ase correct this
97b0: 21 22 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 !").. (set!
97c0: 20 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 waiton (filter
97d0: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
97e0: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
97f0: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 28 waitons))))...(
9800: 63 6f 6e 64 20 0a 0a 09 20 3b 3b 20 69 74 65 6d cond ... ;; item
9810: 73 20 69 73 20 23 66 20 74 68 65 6e 20 74 68 65 s is #f then the
9820: 20 74 65 73 74 20 69 73 20 6f 6b 20 74 6f 20 62 test is ok to b
9830: 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 e handed off to
9840: 6c 61 75 6e 63 68 20 28 62 75 74 20 6e 6f 74 20 launch (but not
9850: 62 65 66 6f 72 65 29 0a 09 20 3b 3b 20 0a 09 20 before).. ;; ..
9860: 28 28 6e 6f 74 20 69 74 65 6d 73 29 0a 09 20 20 ((not items)..
9870: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
9880: 6f 20 34 20 22 4f 55 54 45 52 20 43 4f 4e 44 3a o 4 "OUTER COND:
9890: 20 28 6e 6f 74 20 69 74 65 6d 73 29 22 29 0a 09 (not items)")..
98a0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
98b0: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 (tests:match tes
98c0: 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 3a 74 t-patts (tests:t
98d0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
98e0: 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 tname test-recor
98f0: 64 29 20 69 74 65 6d 2d 70 61 74 68 20 72 65 71 d) item-path req
9900: 75 69 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d uired: required-
9910: 74 65 73 74 73 29 29 0a 09 09 20 20 20 28 6e 6f tests))... (no
9920: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a t (null? tal))).
9930: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 . (loop (ca
9940: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
9950: 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 20 reg reruns))..
9960: 28 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 (let ((loop-list
9970: 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 73 2d 65 (runs:process-e
9980: 78 70 61 6e 64 65 64 2d 74 65 73 74 73 20 68 65 xpanded-tests he
9990: 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 d tal reg reruns
99a0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 20 reglen regfull
99b0: 74 65 73 74 2d 72 65 63 6f 72 64 20 72 75 6e 6e test-record runn
99c0: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
99d0: 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 6f 75 70 em-path jobgroup
99e0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
99f0: 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 61 69 74 jobs run-id wait
9a00: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 74 65 ons item-path te
9a10: 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 61 74 74 stmode test-patt
9a20: 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 s required-tests
9a30: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 72 test-registry r
9a40: 65 67 69 73 74 72 79 2d 6d 75 74 65 78 20 66 6c egistry-mutex fl
9a50: 61 67 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 2d ags keyvals run-
9a60: 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 6c 6c 2d info newtal all-
9a70: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 29 tests-registry))
9a80: 29 0a 09 20 20 20 20 28 69 66 20 6c 6f 6f 70 2d ).. (if loop-
9a90: 6c 69 73 74 20 28 61 70 70 6c 79 20 6c 6f 6f 70 list (apply loop
9aa0: 20 6c 6f 6f 70 2d 6c 69 73 74 29 29 29 29 0a 0a loop-list))))..
9ab0: 09 20 3b 3b 20 69 74 65 6d 73 20 70 72 6f 63 65 . ;; items proce
9ac0: 73 73 65 64 20 69 6e 74 6f 20 61 20 6c 69 73 74 ssed into a list
9ad0: 20 62 75 74 20 6e 6f 74 20 63 61 6d 65 20 69 6e but not came in
9ae0: 20 61 73 20 61 20 6c 69 73 74 20 62 65 65 6e 20 as a list been
9af0: 70 72 6f 63 65 73 73 65 64 0a 09 20 3b 3b 0a 09 processed.. ;;..
9b00: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 ((and (list? it
9b10: 65 6d 73 29 20 20 20 20 20 3b 3b 20 74 68 75 73 ems) ;; thus
9b20: 20 77 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 65 we know our ite
9b30: 6d 73 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 ms are already c
9b40: 61 6c 63 75 6c 61 74 65 64 0a 09 20 20 20 20 20 alculated..
9b50: 20 20 28 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 (not itemdat
9b60: 29 29 20 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 )) ;; and not y
9b70: 65 74 20 65 78 70 61 6e 64 65 64 20 69 6e 74 6f et expanded into
9b80: 20 74 68 65 20 6c 69 73 74 20 6f 66 20 74 68 69 the list of thi
9b90: 6e 67 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 ngs to be done..
9ba0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9bb0: 6e 66 6f 20 34 20 22 4f 55 54 45 52 20 43 4f 4e nfo 4 "OUTER CON
9bc0: 44 3a 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 D: (and (list? i
9bd0: 74 65 6d 73 29 28 6e 6f 74 20 69 74 65 6d 64 61 tems)(not itemda
9be0: 74 29 29 22 29 0a 09 20 20 3b 3b 20 4d 75 73 74 t))").. ;; Must
9bf0: 20 64 65 74 65 72 6d 69 6e 65 20 69 66 20 74 68 determine if th
9c00: 65 20 69 74 65 6d 73 20 6c 69 73 74 20 69 73 20 e items list is
9c10: 76 61 6c 69 64 2e 20 44 69 73 63 61 72 64 20 74 valid. Discard t
9c20: 68 65 20 74 65 73 74 20 69 66 20 69 74 20 69 73 he test if it is
9c30: 20 6e 6f 74 2e 0a 09 20 20 28 69 66 20 28 61 6e not... (if (an
9c40: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 0a d (list? items).
9c50: 09 09 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 .. (> (length
9c60: 69 74 65 6d 73 29 20 30 29 0a 09 09 20 20 20 28 items) 0)... (
9c70: 61 6e 64 20 28 6c 69 73 74 3f 20 28 63 61 72 20 and (list? (car
9c80: 69 74 65 6d 73 29 29 0a 09 09 09 28 3e 20 28 6c items))....(> (l
9c90: 65 6e 67 74 68 20 28 63 61 72 20 69 74 65 6d 73 ength (car items
9ca0: 29 29 20 30 29 29 0a 09 09 20 20 20 28 64 65 62 )) 0))... (deb
9cb0: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 ug:debug-mode 1)
9cc0: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
9cd0: 70 72 69 6e 74 20 32 20 28 6d 61 70 20 28 6c 61 print 2 (map (la
9ce0: 6d 62 64 61 20 28 72 6f 77 29 0a 09 09 09 09 20 mbda (row).....
9cf0: 20 20 20 28 63 6f 6e 63 20 28 73 74 72 69 6e 67 (conc (string
9d00: 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 -intersperse....
9d10: 09 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 .. (map (lambd
9d20: 61 20 28 76 61 72 76 61 6c 29 0a 09 09 09 09 09 a (varval)......
9d30: 09 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
9d40: 73 70 65 72 73 65 20 76 61 72 76 61 6c 20 22 3d sperse varval "=
9d50: 22 29 29 0a 09 09 09 09 09 09 72 6f 77 29 0a 09 ")).......row)..
9d60: 09 09 09 09 20 20 20 22 20 22 29 0a 09 09 09 09 .... " ").....
9d70: 09 20 20 22 5c 6e 22 29 29 0a 09 09 09 09 20 20 . "\n")).....
9d80: 69 74 65 6d 73 29 29 29 0a 09 20 20 28 66 6f 72 items))).. (for
9d90: 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 -each.. (lambd
9da0: 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 a (my-itemdat)..
9db0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 (let* ((new
9dc0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 -test-record (le
9dd0: 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 t ((newrec (make
9de0: 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 -tests:testqueue
9df0: 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 )))..... (
9e00: 76 65 63 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 vector-copy! tes
9e10: 74 2d 72 65 63 6f 72 64 20 6e 65 77 72 65 63 29 t-record newrec)
9e20: 0a 09 09 09 09 20 20 20 20 20 20 20 6e 65 77 72 ..... newr
9e30: 65 63 29 29 0a 09 09 20 20 20 20 28 6d 79 2d 69 ec))... (my-i
9e40: 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c tem-path (item-l
9e50: 69 73 74 2d 3e 70 61 74 68 20 6d 79 2d 69 74 65 ist->path my-ite
9e60: 6d 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 20 mdat)))..
9e70: 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 (if (tests:match
9e80: 20 74 65 73 74 2d 70 61 74 74 73 20 68 65 64 20 test-patts hed
9e90: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 72 65 71 my-item-path req
9ea0: 75 69 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d uired: required-
9eb0: 74 65 73 74 73 29 20 3b 3b 20 28 70 61 74 74 2d tests) ;; (patt-
9ec0: 6c 69 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 74 list-match my-it
9ed0: 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 em-path item-pat
9ee0: 74 73 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b ts) ;;
9ef0: 20 79 65 73 2c 20 77 65 20 77 61 6e 74 20 74 6f yes, we want to
9f00: 20 70 72 6f 63 65 73 73 20 74 68 69 73 20 69 74 process this it
9f10: 65 6d 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 em, NOTE: Should
9f20: 20 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 20 63 not need this c
9f30: 68 65 63 6b 20 68 65 72 65 21 0a 09 09 20 20 20 heck here!...
9f40: 28 6c 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 (let ((newtestna
9f50: 6d 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 me (runs:make-fu
9f60: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 ll-test-name hed
9f70: 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 my-item-path)))
9f80: 20 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 ;; test name
9f90: 73 20 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 s are unique on
9fa0: 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 testname/item-pa
9fb0: 74 68 0a 09 09 20 20 20 20 20 28 74 65 73 74 73 th... (tests
9fc0: 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 :testqueue-set-i
9fd0: 74 65 6d 73 21 20 20 20 20 20 6e 65 77 2d 74 65 tems! new-te
9fe0: 73 74 2d 72 65 63 6f 72 64 20 23 66 29 0a 09 09 st-record #f)...
9ff0: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
a000: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 queue-set-itemda
a010: 74 21 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 t! new-test-re
a020: 63 6f 72 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 cord my-itemdat)
a030: 0a 09 09 20 20 20 20 20 28 74 65 73 74 73 3a 74 ... (tests:t
a040: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
a050: 6d 5f 70 61 74 68 21 20 6e 65 77 2d 74 65 73 74 m_path! new-test
a060: 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d -record my-item-
a070: 70 61 74 68 29 0a 09 09 20 20 20 20 20 28 68 61 path)... (ha
a080: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
a090: 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 77 74 65 st-records newte
a0a0: 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d stname new-test-
a0b0: 72 65 63 6f 72 64 29 0a 09 09 20 20 20 20 20 28 record)... (
a0c0: 73 65 74 21 20 74 61 6c 20 28 61 70 70 65 6e 64 set! tal (append
a0d0: 20 74 61 6c 20 28 6c 69 73 74 20 6e 65 77 74 65 tal (list newte
a0e0: 73 74 6e 61 6d 65 29 29 29 29 29 29 29 20 3b 3b stname))))))) ;;
a0f0: 20 73 69 6e 63 65 20 74 68 65 73 65 20 61 72 65 since these are
a100: 20 69 74 65 6d 69 7a 65 64 20 63 72 65 61 74 65 itemized create
a110: 20 6e 65 77 20 74 65 73 74 20 6e 61 6d 65 73 20 new test names
a120: 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 74 testname/itempat
a130: 68 0a 09 20 20 20 69 74 65 6d 73 29 0a 0a 09 20 h.. items)...
a140: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
a150: 2d 69 6e 66 6f 20 30 20 22 54 65 73 74 20 22 20 -info 0 "Test "
a160: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
a170: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
a180: 73 74 2d 72 65 63 6f 72 64 29 20 22 20 69 73 20 st-record) " is
a190: 69 74 65 6d 69 7a 65 64 20 62 75 74 20 68 61 73 itemized but has
a1a0: 20 6e 6f 20 69 74 65 6d 73 22 29 0a 0a 09 20 20 no items")...
a1b0: 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 ;; At this point
a1c0: 20 77 65 20 68 61 76 65 20 70 6f 73 73 69 62 6c we have possibl
a1d0: 79 20 61 64 64 65 64 20 69 74 65 6d 73 20 74 6f y added items to
a1e0: 20 74 61 6c 20 62 75 74 20 61 6c 6c 20 6d 75 73 tal but all mus
a1f0: 74 20 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 t be handed off
a200: 74 6f 20 0a 09 20 20 3b 3b 20 49 4e 4e 45 52 20 to .. ;; INNER
a210: 43 4f 4e 44 20 6c 6f 67 69 63 2e 20 49 20 74 68 COND logic. I th
a220: 69 6e 6b 20 6c 6f 6f 70 20 77 69 74 68 6f 75 74 ink loop without
a230: 20 72 6f 74 61 74 69 6e 67 20 74 68 65 20 71 75 rotating the qu
a240: 65 75 65 20 0a 09 20 20 3b 3b 20 28 6c 6f 6f 70 eue .. ;; (loop
a250: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
a260: 75 6e 73 29 29 0a 09 20 20 3b 3b 20 28 6c 65 74 uns)).. ;; (let
a270: 20 28 28 6e 65 77 74 61 6c 20 28 61 70 70 65 6e ((newtal (appen
a280: 64 20 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 d tal (list hed)
a290: 29 29 29 20 20 3b 3b 20 57 65 20 73 68 6f 75 6c ))) ;; We shoul
a2a0: 64 20 64 69 73 63 61 72 64 20 68 65 64 20 61 73 d discard hed as
a2b0: 20 69 74 20 68 61 73 20 62 65 65 6e 20 65 78 70 it has been exp
a2c0: 61 6e 64 65 64 20 69 6e 74 6f 20 69 74 27 73 20 anded into it's
a2d0: 69 74 65 6d 73 3f 20 59 65 73 2c 20 62 75 74 20 items? Yes, but
a2e0: 6f 6e 6c 79 20 69 66 20 74 68 69 73 20 2a 69 73 only if this *is
a2f0: 2a 20 61 6e 20 69 74 65 6d 69 7a 65 64 20 74 65 * an itemized te
a300: 73 74 0a 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 28 st.. ;; (loop (
a310: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
a320: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
a330: 6e 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c ns).. (if (null
a340: 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 20 23 66 ? tal).. #f
a350: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
a360: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
a370: 20 72 65 67 20 72 65 72 75 6e 73 29 29 29 0a 09 reg reruns)))..
a380: 20 20 20 20 0a 09 20 3b 3b 20 69 66 20 69 74 65 .. ;; if ite
a390: 6d 73 20 69 73 20 61 20 70 72 6f 63 20 74 68 65 ms is a proc the
a3a0: 6e 20 6e 65 65 64 20 74 6f 20 72 75 6e 20 69 74 n need to run it
a3b0: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
a3c0: 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 om-config, get t
a3d0: 68 65 20 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 he list and loop
a3e0: 20 0a 09 20 3b 3b 20 20 20 20 2d 20 62 75 74 20 .. ;; - but
a3f0: 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 69 66 20 only do that if
a400: 72 65 73 6f 75 72 63 65 73 20 65 78 69 73 74 20 resources exist
a410: 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 20 to kick off the
a420: 6a 6f 62 0a 09 20 3b 3b 20 45 58 50 41 4e 44 20 job.. ;; EXPAND
a430: 49 54 45 4d 53 0a 09 20 28 28 6f 72 20 28 70 72 ITEMS.. ((or (pr
a440: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 ocedure? items)(
a450: 65 71 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d eq? items 'have-
a460: 70 72 6f 63 65 64 75 72 65 29 29 0a 09 20 20 28 procedure)).. (
a470: 6c 65 74 20 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f let ((can-run-mo
a480: 72 65 20 20 20 20 28 72 75 6e 73 3a 63 61 6e 2d re (runs:can-
a490: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 6a run-more-tests j
a4a0: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
a4b0: 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a 09 urrent-jobs)))..
a4c0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 (if (and (li
a4d0: 73 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 st? can-run-more
a4e0: 29 0a 09 09 20 20 20 20 20 28 63 61 72 20 63 61 )... (car ca
a4f0: 6e 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 28 n-run-more))...(
a500: 6c 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 20 let ((loop-list
a510: 28 72 75 6e 73 3a 65 78 70 61 6e 64 2d 69 74 65 (runs:expand-ite
a520: 6d 73 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 ms hed tal reg r
a530: 65 72 75 6e 73 20 72 65 67 66 75 6c 6c 20 6e 65 eruns regfull ne
a540: 77 74 61 6c 20 6a 6f 62 67 72 6f 75 70 20 6d 61 wtal jobgroup ma
a550: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
a560: 73 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 s run-id waitons
a570: 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d item-path testm
a580: 6f 64 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ode test-record
a590: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 69 74 65 can-run-more ite
a5a0: 6d 73 20 72 75 6e 6e 61 6d 65 20 74 63 6f 6e 66 ms runname tconf
a5b0: 69 67 20 72 65 67 6c 65 6e 20 74 65 73 74 2d 72 ig reglen test-r
a5c0: 65 67 69 73 74 72 79 29 29 29 0a 09 09 20 20 28 egistry)))... (
a5d0: 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 0a 09 09 20 if loop-list...
a5e0: 20 20 20 20 20 28 61 70 70 6c 79 20 6c 6f 6f 70 (apply loop
a5f0: 20 6c 6f 6f 70 2d 6c 69 73 74 29 29 29 0a 09 09 loop-list)))...
a600: 3b 3b 20 69 66 20 63 61 6e 27 74 20 72 75 6e 20 ;; if can't run
a610: 6d 6f 72 65 20 6a 75 73 74 20 6c 6f 6f 70 20 77 more just loop w
a620: 69 74 68 20 6e 65 78 74 20 70 6f 73 73 69 62 6c ith next possibl
a630: 65 20 74 65 73 74 0a 09 09 28 6c 6f 6f 70 20 28 e test...(loop (
a640: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
a650: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
a660: 6e 73 29 29 29 29 0a 09 20 20 20 20 0a 09 20 3b ns)))).. .. ;
a670: 3b 20 74 68 69 73 20 63 61 73 65 20 73 68 6f 75 ; this case shou
a680: 6c 64 20 6e 6f 74 20 68 61 70 70 65 6e 2c 20 61 ld not happen, a
a690: 64 64 65 64 20 74 6f 20 68 65 6c 70 20 63 61 74 dded to help cat
a6a0: 63 68 20 61 6e 79 20 62 75 67 73 0a 09 20 28 28 ch any bugs.. ((
a6b0: 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 and (list? items
a6c0: 29 20 69 74 65 6d 64 61 74 29 0a 09 20 20 28 64 ) itemdat).. (d
a6d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
a6e0: 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 ROR: Should not
a6f0: 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 69 have a list of i
a700: 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 61 tems in a test a
a710: 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 68 nd the itemspath
a720: 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 65 set - please re
a730: 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 28 port this").. (
a740: 65 78 69 74 20 31 29 29 0a 09 20 28 28 6e 6f 74 exit 1)).. ((not
a750: 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 (null? reruns))
a760: 0a 09 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 6c .. (let* ((newl
a770: 73 74 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 st (tests:filter
a780: 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 -non-runnable ru
a790: 6e 2d 69 64 20 74 61 6c 20 74 65 73 74 2d 72 65 n-id tal test-re
a7a0: 63 6f 72 64 73 29 29 20 3b 3b 20 69 2e 65 2e 20 cords)) ;; i.e.
a7b0: 6e 6f 74 20 46 41 49 4c 2c 20 57 41 49 56 45 44 not FAIL, WAIVED
a7c0: 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 , INCOMPLETE, PA
a7d0: 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 20 28 SS, KILLED,... (
a7e0: 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 69 66 junked (lset-dif
a7f0: 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f 20 74 ference equal? t
a800: 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 20 20 al newlst)))..
a810: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
a820: 6e 66 6f 20 34 20 22 66 75 6c 6c 20 64 72 6f 70 nfo 4 "full drop
a830: 20 74 68 72 6f 75 67 68 2c 20 69 66 20 72 65 72 through, if rer
a840: 75 6e 73 20 69 73 20 6c 65 73 73 20 74 68 61 6e uns is less than
a850: 20 31 30 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 100 we will for
a860: 63 65 20 72 65 74 72 79 20 74 68 65 6d 2c 20 72 ce retry them, r
a870: 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 eruns=" reruns "
a880: 2c 20 74 61 6c 3d 22 20 74 61 6c 29 0a 09 20 20 , tal=" tal)..
a890: 20 20 28 69 66 20 28 3c 20 6e 75 6d 2d 72 65 74 (if (< num-ret
a8a0: 72 69 65 73 20 6d 61 78 2d 72 65 74 72 69 65 73 ries max-retries
a8b0: 29 0a 09 09 28 73 65 74 21 20 6e 65 77 6c 73 74 )...(set! newlst
a8c0: 20 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 (append reruns
a8d0: 6e 65 77 6c 73 74 29 29 29 0a 09 20 20 20 20 28 newlst))).. (
a8e0: 73 65 74 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 set! num-retries
a8f0: 20 28 2b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 (+ num-retries
a900: 31 29 29 0a 09 20 20 20 20 3b 3b 20 28 74 68 72 1)).. ;; (thr
a910: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 ead-sleep! (+ 1
a920: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
a930: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
a940: 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 29 29 0a 09 null? newlst))..
a950: 09 3b 3b 20 73 69 6e 63 65 20 72 65 72 75 6e 73 .;; since reruns
a960: 20 68 61 76 65 20 62 65 65 6e 20 74 61 63 6b 65 have been tacke
a970: 64 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 74 20 63 d on to newlst c
a980: 72 65 61 74 65 20 6e 65 77 20 72 65 72 75 6e 73 reate new reruns
a990: 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a 09 09 28 from junked...(
a9a0: 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 6c 73 74 loop (car newlst
a9b0: 29 28 63 64 72 20 6e 65 77 6c 73 74 29 20 72 65 )(cdr newlst) re
a9c0: 67 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 g (delete-duplic
a9d0: 61 74 65 73 20 6a 75 6e 6b 65 64 29 29 29 29 29 ates junked)))))
a9e0: 0a 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 .. ((not (null?
a9f0: 74 61 6c 29 29 0a 09 20 20 28 64 65 62 75 67 3a tal)).. (debug:
aa00: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 49 27 print-info 4 "I'
aa10: 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 49 20 m pretty sure I
aa20: 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 shouldn't get he
aa30: 72 65 2e 22 29 29 0a 09 20 28 28 6e 6f 74 20 28 re.")).. ((not (
aa40: 6e 75 6c 6c 3f 20 72 65 67 29 29 20 3b 3b 20 63 null? reg)) ;; c
aa50: 6f 75 6c 64 20 77 65 20 67 65 74 20 68 65 72 65 ould we get here
aa60: 20 77 69 74 68 20 6c 65 66 74 6f 76 65 72 73 3f with leftovers?
aa70: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
aa80: 2d 69 6e 66 6f 20 30 20 22 48 61 76 65 20 6c 65 -info 0 "Have le
aa90: 66 74 6f 76 65 72 73 21 22 29 0a 09 20 20 28 6c ftovers!").. (l
aaa0: 6f 6f 70 20 28 63 61 72 20 72 65 67 29 28 63 64 oop (car reg)(cd
aab0: 72 20 72 65 67 29 20 27 28 29 20 72 65 72 75 6e r reg) '() rerun
aac0: 73 29 29 0a 09 20 28 65 6c 73 65 0a 09 20 20 28 s)).. (else.. (
aad0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
aae0: 20 34 20 22 45 78 69 74 69 6e 67 20 6c 6f 6f 70 4 "Exiting loop
aaf0: 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 68 65 64 3d with...\n hed=
ab00: 22 20 68 65 64 20 22 5c 6e 20 20 74 61 6c 3d 22 " hed "\n tal="
ab10: 20 74 61 6c 20 22 5c 6e 20 20 72 65 72 75 6e 73 tal "\n reruns
ab20: 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 20 29 29 =" reruns)).. ))
ab30: 29 20 3b 3b 20 4c 45 54 2a 20 28 28 74 65 73 74 ) ;; LET* ((test
ab40: 2d 72 65 63 6f 72 64 0a 20 20 20 20 0a 20 20 20 -record. .
ab50: 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 20 ;; we get here
ab60: 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 68 on "drop through
ab70: 22 2e 20 41 6c 6c 20 64 6f 6e 65 21 0a 20 20 20 ". All done!.
ab80: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
ab90: 66 6f 20 31 20 22 41 6c 6c 20 74 65 73 74 73 20 fo 1 "All tests
aba0: 6c 61 75 6e 63 68 65 64 22 29 29 29 0a 0a 28 64 launched")))..(d
abb0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
abc0: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
abd0: 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 ot-met). (filte
abe0: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
abf0: 0a 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 .. (and (vect
ac00: 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 or? test) ;; not
ac10: 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 (string? test))
ac20: 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a ... (equal? (db:
ac30: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
ac40: 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 est) "COMPLETED"
ac50: 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 )... (not (membe
ac60: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
ac70: 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 tatus test)....
ac80: 20 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 '("PASS" "W
ac90: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 ARN" "CHECK" "WA
aca0: 49 56 45 44 22 20 22 53 4b 49 50 22 29 29 29 29 IVED" "SKIP"))))
acb0: 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ).. prereqs-not
acc0: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
acd0: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
ace0: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
acf0: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
ad00: 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ter. (lambda (
ad10: 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 t). (or (not
ad20: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
ad30: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f (not (equal? "CO
ad40: 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 MPLETED" (db:tes
ad50: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 t-get-state t)))
ad60: 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f )). prereqs-no
ad70: 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 t-met))..(define
ad80: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
ad90: 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 70 ring lst). (map
ada0: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 28 (lambda (t).. (
adb0: 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f if (not (vector?
adc0: 20 74 29 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 t)).. (conc
add0: 20 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 t).. (conc
ade0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
adf0: 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 tname t) ":" (db
ae00: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
ae10: 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d t) "/" (db:test-
ae20: 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 get-status t))))
ae30: 0a 20 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 28 . lst))..(
ae40: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6d 61 6b define (runs:mak
ae50: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
ae60: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
ae70: 74 68 29 0a 20 20 28 69 66 20 28 65 71 75 61 6c th). (if (equal
ae80: 3f 20 69 74 65 6d 70 61 74 68 20 22 22 29 20 74 ? itempath "") t
ae90: 65 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 estname (conc te
aea0: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 stname "/" itemp
aeb0: 61 74 68 29 29 29 0a 0a 3b 3b 20 70 61 72 65 6e ath)))..;; paren
aec0: 74 2d 74 65 73 74 20 69 73 20 74 68 65 72 65 20 t-test is there
aed0: 61 73 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 as a placeholder
aee0: 20 66 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 for when parent
aef0: 2d 74 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 -tests can be ru
af00: 6e 20 61 73 20 61 20 73 65 74 75 70 20 73 74 65 n as a setup ste
af10: 70 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 p.(define (run:t
af20: 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 est run-id run-i
af30: 6e 66 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e nfo keyvals runn
af40: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ame test-record
af50: 66 6c 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 flags parent-tes
af60: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
af70: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
af80: 72 79 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 ry). ;; All the
af90: 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 se vars might be
afa0: 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 referenced by t
afb0: 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 he testconfig fi
afc0: 6c 65 20 72 65 61 64 65 72 0a 20 20 28 6c 65 74 le reader. (let
afd0: 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 * ((test-name
afe0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
aff0: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
b000: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
b010: 20 28 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 (test-waitons (
b020: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
b030: 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 get-waitons t
b040: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
b050: 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 test-conf (te
b060: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
b070: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 t-testconfig tes
b080: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 t-record)).. (it
b090: 65 6d 64 61 74 20 20 20 20 20 20 28 74 65 73 74 emdat (test
b0a0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
b0b0: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
b0c0: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
b0d0: 2d 70 61 74 68 20 20 20 20 28 68 61 73 68 2d 74 -path (hash-t
b0e0: 61 62 6c 65 2d 72 65 66 20 61 6c 6c 2d 74 65 73 able-ref all-tes
b0f0: 74 73 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 ts-registry test
b100: 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 6f 6e 63 -name)) ;; (conc
b110: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
b120: 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 ts/" test-name))
b130: 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 ;; could use te
b140: 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 sts:get-testconf
b150: 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 ig here ..... (f
b160: 6f 72 63 65 20 20 20 20 20 20 20 20 28 68 61 73 orce (has
b170: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
b180: 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 ult flags "-forc
b190: 65 22 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e e" #f)).. (rerun
b1a0: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
b1b0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
b1c0: 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 flags "-rerun" #
b1d0: 66 29 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 f)).. (keepgoing
b1e0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
b1f0: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
b200: 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 s "-keepgoing" #
b210: 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 f)).. (item-path
b220: 20 20 20 20 20 22 22 29 0a 09 20 28 64 62 20 20 "").. (db
b230: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 #f).. (
b240: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 23 full-test-name #
b250: 66 29 29 0a 0a 20 20 20 20 3b 3b 20 73 65 74 74 f)).. ;; sett
b260: 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 ing itemdat to a
b270: 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 20 23 list if it is #
b280: 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 f. (if (not i
b290: 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 temdat)(set! ite
b2a0: 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 mdat '())). (
b2b0: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 set! item-path (
b2c0: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path
b2d0: 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 73 itemdat)). (s
b2e0: 65 74 21 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 et! full-test-na
b2f0: 6d 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 me (runs:make-fu
b300: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ll-test-name tes
b310: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
b320: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
b330: 69 6e 74 2d 69 6e 66 6f 20 34 0a 09 09 20 20 20 int-info 4...
b340: 20 20 20 22 5c 6e 54 45 53 54 4e 41 4d 45 3a 20 "\nTESTNAME:
b350: 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 " full-test-name
b360: 20 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 20 20 ... "\n
b370: 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 test-config: " (
b380: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
b390: 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 t test-conf)...
b3a0: 20 20 20 20 20 22 5c 6e 20 20 20 69 74 65 6d 64 "\n itemd
b3b0: 61 74 3a 20 22 20 69 74 65 6d 64 61 74 0a 09 09 at: " itemdat...
b3c0: 20 20 20 20 20 20 29 0a 20 20 20 20 28 64 65 62 ). (deb
b3d0: 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 ug:print 2 "Atte
b3e0: 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 mpting to launch
b3f0: 20 74 65 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 test " full-tes
b400: 74 2d 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 74 t-name). (set
b410: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d env "MT_TEST_NAM
b420: 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b E" test-name) ;;
b430: 20 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d . (setenv "M
b440: 54 5f 49 54 45 4d 50 41 54 48 22 20 20 69 74 65 T_ITEMPATH" ite
b450: 6d 2d 70 61 74 68 29 0a 20 20 20 20 28 73 65 74 m-path). (set
b460: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
b470: 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 runname).
b480: 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e (set-megatest-en
b490: 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 69 6e v-vars run-id in
b4a0: 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d 65 runname: runname
b4b0: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
b4c0: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
b4d0: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
b4e0: 73 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 s. (change-di
b4f0: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
b500: 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 65 72 65 20 *).. ;; Here
b510: 69 73 20 77 68 65 72 65 20 74 68 65 20 74 65 73 is where the tes
b520: 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 69 73 20 t_meta table is
b530: 62 65 73 74 20 75 70 64 61 74 65 64 0a 20 20 20 best updated.
b540: 20 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 68 65 72 ;; Yes, another
b550: 20 75 73 65 20 6f 66 20 61 20 67 6c 6f 62 61 6c use of a global
b560: 20 66 6f 72 20 63 61 63 68 69 6e 67 2e 20 4e 65 for caching. Ne
b570: 65 64 20 61 20 62 65 74 74 65 72 20 77 61 79 3f ed a better way?
b580: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 . (if (not (h
b590: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
b5a0: 66 61 75 6c 74 20 2a 74 65 73 74 2d 6d 65 74 61 fault *test-meta
b5b0: 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e -updated* test-n
b5c0: 61 6d 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 ame #f)).
b5d0: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 68 61 73 (begin.. (has
b5e0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 h-table-set! *te
b5f0: 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a st-meta-updated*
b600: 20 74 65 73 74 2d 6e 61 6d 65 20 23 74 29 0a 20 test-name #t).
b610: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a (runs:
b620: 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 update-test_meta
b630: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
b640: 63 6f 6e 66 29 29 29 0a 20 20 20 20 0a 20 20 20 conf))). .
b650: 20 3b 3b 20 69 74 65 6d 64 61 74 20 3d 3e 20 28 ;; itemdat => (
b660: 28 72 69 70 65 6e 65 73 73 20 22 6f 76 65 72 72 (ripeness "overr
b670: 69 70 65 22 29 20 28 74 65 6d 70 65 72 61 74 75 ipe") (temperatu
b680: 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 re "cool") (seas
b690: 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 0a 20 20 on "summer")).
b6a0: 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 (let* ((new-te
b6b0: 73 74 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d st-path (string-
b6c0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 63 6f 6e intersperse (con
b6d0: 73 20 74 65 73 74 2d 70 61 74 68 20 28 6d 61 70 s test-path (map
b6e0: 20 63 61 64 72 20 69 74 65 6d 64 61 74 29 29 20 cadr itemdat))
b6f0: 22 2f 22 29 29 0a 09 20 20 20 28 74 65 73 74 2d "/")).. (test-
b700: 69 64 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 id (cdb:re
b710: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
b720: 74 65 73 74 2d 69 64 20 23 66 20 20 72 75 6e 2d test-id #f run-
b730: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
b740: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 28 74 65 m-path)).. (te
b750: 73 74 64 61 74 20 20 20 20 20 20 20 28 63 64 62 stdat (cdb
b760: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
b770: 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a y-id *runremote*
b780: 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 test-id))).
b790: 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 (if (not testd
b7a0: 61 74 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 at).. (let loop
b7b0: 20 28 29 0a 09 20 20 20 20 3b 3b 20 65 6e 73 75 ().. ;; ensu
b7c0: 72 65 20 74 68 61 74 20 74 68 65 20 70 61 74 68 re that the path
b7d0: 20 65 78 69 73 74 73 20 62 65 66 6f 72 65 20 72 exists before r
b7e0: 65 67 69 73 74 65 72 69 6e 67 20 74 68 65 20 74 egistering the t
b7f0: 65 73 74 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 45 est.. ;; NOPE
b800: 3a 20 43 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 : Cannot! Don't
b810: 6b 6e 6f 77 20 79 65 74 20 77 68 69 63 68 20 64 know yet which d
b820: 69 73 6b 20 61 72 65 61 20 77 69 6c 6c 20 62 65 isk area will be
b830: 20 61 73 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 assigned......
b840: 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 ;; (system (c
b850: 6f 6e 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 onc "mkdir -p "
b860: 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 29 29 0a new-test-path)).
b870: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 . ;;.. ;;
b880: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
b890: 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 2d 74 tests:register-t
b8a0: 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 est db run-id te
b8b0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
b8c0: 68 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 h).. ;;..
b8d0: 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 74 68 65 20 ;; NB// for the
b8e0: 61 62 6f 76 65 20 6c 69 6e 65 2e 20 49 20 77 61 above line. I wa
b8f0: 6e 74 20 74 68 65 20 74 65 73 74 20 74 6f 20 62 nt the test to b
b900: 65 20 72 65 67 69 73 74 65 72 65 64 20 6c 6f 6e e registered lon
b910: 67 20 62 65 66 6f 72 65 20 74 68 69 73 20 72 6f g before this ro
b920: 75 74 69 6e 65 20 67 65 74 73 20 63 61 6c 6c 65 utine gets calle
b930: 64 21 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 d!.. ;;..
b940: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 63 (set! test-id (c
b950: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
b960: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 23 66 20 :get-test-id #f
b970: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
b980: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
b990: 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 2d (if (not test-
b9a0: 69 64 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 id)...(begin...
b9b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
b9c0: 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 "WARN: Test not
b9d0: 70 72 65 2d 63 72 65 61 74 65 64 3f 20 74 65 73 pre-created? tes
b9e0: 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 t-name=" test-na
b9f0: 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d me ", item-path=
ba00: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 2c 20 72 " item-path ", r
ba10: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a un-id=" run-id).
ba20: 09 09 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 .. (cdb:tests-r
ba30: 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 egister-test *ru
ba40: 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 nremote* run-id
ba50: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
ba60: 61 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 74 ath)... (set! t
ba70: 65 73 74 2d 69 64 20 28 63 64 62 3a 72 65 6d 6f est-id (cdb:remo
ba80: 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 te-run db:get-te
ba90: 73 74 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 20 st-id #f run-id
baa0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
bab0: 61 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 65 ath)))).. (de
bac0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
bad0: 20 22 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 "test-id=" test
bae0: 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 -id ", run-id="
baf0: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e run-id ", test-n
bb00: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
bb10: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 ", item-path=\""
bb20: 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 item-path "\"")
bb30: 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
bb40: 64 61 74 20 28 63 64 62 3a 67 65 74 2d 74 65 73 dat (cdb:get-tes
bb50: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
bb60: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
bb70: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
bb80: 20 74 65 73 74 64 61 74 29 0a 09 09 28 62 65 67 testdat)...(beg
bb90: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
bba0: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 41 52 4e int-info 0 "WARN
bbb0: 49 4e 47 3a 20 73 65 72 76 65 72 20 69 73 20 6f ING: server is o
bbc0: 76 65 72 6c 6f 61 64 65 64 2c 20 74 72 79 69 6e verloaded, tryin
bbd0: 67 20 61 67 61 69 6e 20 69 6e 20 6f 6e 65 20 73 g again in one s
bbe0: 65 63 6f 6e 64 22 29 0a 09 09 20 20 28 74 68 72 econd")... (thr
bbf0: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 ead-sleep! 1)...
bc00: 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a 20 20 20 (loop))))).
bc10: 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 (if (not test
bc20: 64 61 74 29 20 3b 3b 20 73 68 6f 75 6c 64 20 4e dat) ;; should N
bc30: 4f 54 20 68 61 70 70 65 6e 0a 09 20 20 28 64 65 OT happen.. (de
bc40: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
bc50: 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 67 65 OR: failed to ge
bc60: 74 20 74 65 73 74 20 72 65 63 6f 72 64 20 66 6f t test record fo
bc70: 72 20 74 65 73 74 2d 69 64 20 22 20 74 65 73 74 r test-id " test
bc80: 2d 69 64 29 29 0a 20 20 20 20 20 20 28 73 65 74 -id)). (set
bc90: 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a 74 65 ! test-id (db:te
bca0: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
bcb0: 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 66 t)). (if (f
bcc0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 ile-exists? test
bcd0: 2d 70 61 74 68 29 0a 09 20 20 28 63 68 61 6e 67 -path).. (chang
bce0: 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 e-directory test
bcf0: 2d 70 61 74 68 29 0a 09 20 20 28 62 65 67 69 6e -path).. (begin
bd00: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
bd10: 6e 74 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 nt "ERROR: test
bd20: 72 75 6e 20 70 61 74 68 20 6e 6f 74 20 63 72 65 run path not cre
bd30: 61 74 65 64 20 62 65 66 6f 72 65 20 61 74 74 65 ated before atte
bd40: 6d 70 74 69 6e 67 20 74 6f 20 72 75 6e 20 74 68 mpting to run th
bd50: 65 20 74 65 73 74 2e 20 50 65 72 68 61 70 73 20 e test. Perhaps
bd60: 79 6f 75 20 61 72 65 20 72 75 6e 6e 69 6e 67 20 you are running
bd70: 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 20 61 74 20 -remove-runs at
bd80: 74 68 65 20 73 61 6d 65 20 74 69 6d 65 3f 22 29 the same time?")
bd90: 0a 09 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 .. (change-di
bda0: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
bdb0: 2a 29 29 29 0a 20 20 20 20 20 20 28 63 61 73 65 *))). (case
bdc0: 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 61 (if force ;; (a
bdd0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f rgs:get-arg "-fo
bde0: 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 41 rce")...'NOT_STA
bdf0: 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 74 64 RTED...(if testd
be00: 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 at... (string
be10: 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 ->symbol (test:g
be20: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
be30: 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c 65 64 ))... 'failed
be40: 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 28 -to-insert))..((
be50: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
be60: 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ).. (debug:print
be70: 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 0 "ERROR: Faile
be80: 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 65 20 d to insert the
be90: 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 20 record into the
bea0: 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 41 db"))..((NOT_STA
beb0: 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 20 44 RTED COMPLETED D
bec0: 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 20 28 ELETED).. (let (
bed0: 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 (runflag #f))..
bee0: 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 (cond.. ;;
bef0: 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d -force, run no m
bf00: 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 atter what..
bf10: 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e (force (set! run
bf20: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
bf30: 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 ; NOT_STARTED, r
bf40: 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 un no matter wha
bf50: 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 72 20 t.. ((member
bf60: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
bf70: 74 65 73 74 64 61 74 29 20 27 28 22 44 45 4c 45 testdat) '("DELE
bf80: 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 TED" "NOT_STARTE
bf90: 44 22 29 29 28 73 65 74 21 20 72 75 6e 66 6c 61 D"))(set! runfla
bfa0: 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e g #t)).. ;; n
bfb0: 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 ot -rerun and PA
bfc0: 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 SS, WARN or CHEC
bfd0: 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 K, do no run..
bfe0: 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 ((and (or (not
bff0: 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 20 20 rerun)...
c000: 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b keepgoing)... ;
c010: 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 6f 72 ; Require to for
c020: 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f ce re-run for CO
c030: 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 MPLETED or *anyt
c040: 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 hing* + PASS,WAR
c050: 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 20 28 N or CHECK... (
c060: 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 or (member (test
c070: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
c080: 64 61 74 29 20 27 28 22 50 41 53 53 22 20 22 57 dat) '("PASS" "W
c090: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 53 4b ARN" "CHECK" "SK
c0a0: 49 50 22 20 22 57 41 49 56 45 44 22 29 29 0a 09 IP" "WAIVED"))..
c0b0: 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 . (member (
c0c0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 20 test:get-state
c0d0: 74 65 73 74 64 61 74 29 20 27 28 22 43 4f 4d 50 testdat) '("COMP
c0e0: 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 20 20 LETED")))) ..
c0f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
c100: 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 20 74 nfo 2 "running t
c110: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
c120: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 "/" item-path "
c130: 73 75 70 70 72 65 73 73 65 64 20 61 73 20 69 74 suppressed as it
c140: 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 74 2d is " (test:get-
c150: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 22 state testdat) "
c160: 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 65 74 and " (test:get
c170: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
c180: 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 ).. (hash-ta
c190: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
c1a0: 67 69 73 74 72 79 20 66 75 6c 6c 2d 74 65 73 74 gistry full-test
c1b0: 2d 6e 61 6d 65 20 27 44 4f 4e 4f 54 52 55 4e 29 -name 'DONOTRUN)
c1c0: 20 3b 3b 20 43 4f 4d 50 4c 45 54 45 44 29 0a 09 ;; COMPLETED)..
c1d0: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
c1e0: 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 ag #f)).. ;;
c1f0: 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 74 75 -rerun and statu
c200: 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 s is one of the
c210: 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 69 74 specifed, run it
c220: 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 72 75 .. ((and reru
c230: 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 72 65 n... (let* ((re
c240: 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 6e 67 runlst (string
c250: 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 -split rerun ","
c260: 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 65 72 )).... (must-rer
c270: 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 un (member (test
c280: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
c290: 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 29 29 dat) rerunlst)))
c2a0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
c2b0: 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d 72 65 72 int-info 3 "-rer
c2c0: 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 75 6e un list: " rerun
c2d0: 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 73 3a ", test-status:
c2e0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
c2f0: 74 75 73 20 74 65 73 74 64 61 74 29 22 2c 20 6d tus testdat)", m
c300: 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d 75 73 ust-rerun: " mus
c310: 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 20 6d t-rerun)... m
c320: 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 20 20 ust-rerun))..
c330: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
c340: 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 66 6f 72 nfo 2 "Rerun for
c350: 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 20 74 ced for test " t
c360: 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 est-name "/" ite
c370: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 28 73 m-path).. (s
c380: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
c390: 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f .. ;; -keepgo
c3a0: 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 ing, do not reru
c3b0: 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 61 6e n FAIL.. ((an
c3c0: 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 d keepgoing...
c3d0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
c3e0: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
c3f0: 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a 09 20 ) '("FAIL")))..
c400: 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 (set! runfla
c410: 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 61 6e g #f)).. ((an
c420: 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 d (not rerun)...
c430: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
c440: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
c450: 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 6e 2f at) '("FAIL" "n/
c460: 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 a"))).. (set
c470: 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 ! runflag #t))..
c480: 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 21 20 (else (set!
c490: 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a 09 20 runflag #f)))..
c4a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
c4b0: 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e "RUNNING => run
c4c0: 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 flag: " runflag
c4d0: 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 73 74 " STATE: " (test
c4e0: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
c4f0: 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 22 20 at) " STATUS: "
c500: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
c510: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 28 testdat)).. (
c520: 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 if (not runflag)
c530: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f .. (if (no
c540: 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 t parent-test)..
c550: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
c560: 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 1 "NOTE: Not st
c570: 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 66 75 arting test " fu
c580: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 ll-test-name " a
c590: 73 20 69 74 20 69 73 20 73 74 61 74 65 20 5c 22 s it is state \"
c5a0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
c5b0: 65 20 74 65 73 74 64 61 74 29 20 0a 09 09 09 09 e testdat) .....
c5c0: 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 5c "\" and status \
c5d0: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
c5e0: 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c 22 tus testdat) "\"
c5f0: 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 22 , use -rerun \""
c600: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
c610: 73 20 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 s testdat).
c620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c630: 20 20 20 20 20 20 20 20 20 20 20 22 5c 22 20 6f "\" o
c640: 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 72 r -force to over
c650: 72 69 64 65 22 29 29 0a 09 20 20 20 20 20 20 20 ride"))..
c660: 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 ;; NOTE: No long
c670: 65 72 20 62 65 20 63 68 65 63 6b 69 6e 67 20 70 er be checking p
c680: 72 65 72 65 71 75 69 73 69 74 65 73 20 68 65 72 rerequisites her
c690: 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 20 67 65 e! Will never ge
c6a0: 74 20 68 65 72 65 20 75 6e 6c 65 73 73 20 70 72 t here unless pr
c6b0: 65 72 65 71 73 20 61 72 65 0a 09 20 20 20 20 20 ereqs are..
c6c0: 20 20 3b 3b 20 20 20 20 20 20 20 61 6c 72 65 61 ;; alrea
c6d0: 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 20 20 20 dy met...
c6e0: 3b 3b 20 54 68 69 73 20 77 6f 75 6c 64 20 62 65 ;; This would be
c6f0: 20 61 20 67 72 65 61 74 20 70 6c 61 63 65 20 74 a great place t
c700: 6f 20 64 6f 20 74 68 65 20 70 72 6f 63 65 73 73 o do the process
c710: 2d 66 6f 72 6b 0a 09 20 20 20 20 20 20 20 3b 3b -fork.. ;;
c720: 20 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 .. (let (
c730: 28 73 6b 69 70 2d 74 65 73 74 20 20 20 23 66 29 (skip-test #f)
c740: 0a 09 09 20 20 20 20 20 28 73 6b 69 70 2d 63 68 ... (skip-ch
c750: 65 63 6b 20 20 28 63 6f 6e 66 69 67 66 3a 67 65 eck (configf:ge
c760: 74 2d 73 65 63 74 69 6f 6e 20 74 65 73 74 2d 63 t-section test-c
c770: 6f 6e 66 20 22 73 6b 69 70 22 29 29 29 0a 09 09 onf "skip")))...
c780: 20 28 63 6f 6e 64 20 0a 09 09 20 20 3b 3b 20 48 (cond ... ;; H
c790: 61 76 65 20 74 6f 20 63 68 65 63 6b 20 66 6f 72 ave to check for
c7a0: 20 73 6b 69 70 20 63 6f 6e 64 69 74 69 6f 6e 73 skip conditions
c7b0: 2e 20 54 68 69 73 20 6f 6e 65 20 73 6b 69 70 73 . This one skips
c7c0: 20 69 66 20 74 68 65 72 65 20 61 72 65 20 73 61 if there are sa
c7d0: 6d 65 2d 6e 61 6d 65 64 20 74 65 73 74 73 0a 09 me-named tests..
c7e0: 09 20 20 3b 3b 20 63 75 72 72 65 6e 74 6c 79 20 . ;; currently
c7f0: 72 75 6e 6e 69 6e 67 0a 09 09 20 20 28 28 61 6e running... ((an
c800: 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a 09 09 09 d skip-check....
c810: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
c820: 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 test-conf "skip"
c830: 20 22 70 72 65 76 72 75 6e 6e 69 6e 67 22 29 29 "prevrunning"))
c840: 0a 09 09 20 20 20 28 6c 65 74 20 28 28 72 75 6e ... (let ((run
c850: 6e 69 6e 67 2d 74 65 73 74 73 20 28 63 64 62 3a ning-tests (cdb:
c860: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 remote-run db:ge
c870: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 t-tests-for-runs
c880: 2d 6d 69 6e 64 61 74 61 20 23 66 20 23 66 20 66 -mindata #f #f f
c890: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 28 ull-test-name '(
c8a0: 22 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 "RUNNING" "REMOT
c8b0: 45 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 EHOSTSTART" "LAU
c8c0: 4e 43 48 45 44 22 29 20 27 28 29 20 23 66 29 29 NCHED") '() #f))
c8d0: 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f )... (if (no
c8e0: 74 20 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 6e 67 t (null? running
c8f0: 2d 74 65 73 74 73 29 29 20 3b 3b 20 68 61 76 65 -tests)) ;; have
c900: 20 74 6f 20 73 6b 69 70 20 0a 09 09 09 20 28 73 to skip .... (s
c910: 65 74 21 20 73 6b 69 70 2d 74 65 73 74 20 22 53 et! skip-test "S
c920: 6b 69 70 70 69 6e 67 20 64 75 65 20 74 6f 20 70 kipping due to p
c930: 72 65 76 69 6f 75 73 20 74 65 73 74 73 20 72 75 revious tests ru
c940: 6e 6e 69 6e 67 22 29 29 29 29 0a 09 09 20 20 28 nning"))))... (
c950: 28 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a (and skip-check.
c960: 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b ...(configf:look
c970: 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b up test-conf "sk
c980: 69 70 22 20 22 66 69 6c 65 65 78 69 73 74 73 22 ip" "fileexists"
c990: 29 29 0a 09 09 20 20 20 28 69 66 20 28 66 69 6c ))... (if (fil
c9a0: 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 66 69 e-exists? (confi
c9b0: 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 gf:lookup test-c
c9c0: 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 69 6c 65 onf "skip" "file
c9d0: 65 78 69 73 74 73 22 29 29 0a 09 09 20 20 20 20 exists"))...
c9e0: 20 20 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 (set! skip-te
c9f0: 73 74 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 st (conc "Skippi
ca00: 6e 67 20 64 75 65 20 74 6f 20 65 78 69 73 74 61 ng due to exista
ca10: 6e 63 65 20 6f 66 20 66 69 6c 65 20 22 20 28 63 nce of file " (c
ca20: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 onfigf:lookup te
ca30: 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 st-conf "skip" "
ca40: 66 69 6c 65 65 78 69 73 74 73 22 29 29 29 29 29 fileexists")))))
ca50: 29 0a 09 09 20 28 69 66 20 73 6b 69 70 2d 74 65 )... (if skip-te
ca60: 73 74 0a 09 09 20 20 20 20 20 28 62 65 67 69 6e st... (begin
ca70: 0a 09 09 20 20 20 20 20 20 20 28 6d 74 3a 74 65 ... (mt:te
ca80: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
ca90: 74 75 73 2d 62 79 2d 69 64 20 74 65 73 74 2d 69 tus-by-id test-i
caa0: 64 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 53 d "COMPLETED" "S
cab0: 4b 49 50 22 20 73 6b 69 70 2d 74 65 73 74 29 0a KIP" skip-test).
cac0: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
cad0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 53 4b print-info 1 "SK
cae0: 49 50 50 49 4e 47 20 54 65 73 74 20 22 20 66 75 IPPING Test " fu
caf0: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 64 ll-test-name " d
cb00: 75 65 20 74 6f 20 22 20 73 6b 69 70 2d 74 65 73 ue to " skip-tes
cb10: 74 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 t))... (if (
cb20: 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 not (launch-test
cb30: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
cb40: 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c 73 run-info keyvals
cb50: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f runname test-co
cb60: 6e 66 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 nf test-name tes
cb70: 74 2d 70 61 74 68 20 69 74 65 6d 64 61 74 20 66 t-path itemdat f
cb80: 6c 61 67 73 29 29 0a 09 09 09 20 28 62 65 67 69 lags)).... (begi
cb90: 6e 0a 09 09 09 20 20 20 28 70 72 69 6e 74 20 22 n.... (print "
cba0: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
cbb0: 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 74 launch the test
cbc0: 2e 20 45 78 69 74 69 6e 67 20 61 73 20 73 6f 6f . Exiting as soo
cbd0: 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 22 29 0a n as possible").
cbe0: 09 09 09 20 20 20 28 73 65 74 21 20 2a 67 6c 6f ... (set! *glo
cbf0: 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 balexitstatus* 1
cc00: 29 20 3b 3b 20 0a 09 09 09 20 20 20 28 70 72 6f ) ;; .... (pro
cc10: 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 cess-signal (cur
cc20: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
cc30: 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 signal/kill))))
cc40: 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 29 20 ))))..((KILLED)
cc50: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
cc60: 31 20 22 4e 4f 54 45 3a 20 22 20 66 75 6c 6c 2d 1 "NOTE: " full-
cc70: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
cc80: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f lready running o
cc90: 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c 79 20 r was explictly
cca0: 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 killed, use -for
ccb0: 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e ce to launch it.
ccc0: 22 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 ").. (hash-table
ccd0: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
cce0: 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 try (runs:make-f
ccf0: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
cd00: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat
cd10: 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 20 3b h) 'DONOTRUN)) ;
cd20: 3b 20 4b 49 4c 4c 45 44 29 29 0a 09 28 28 4c 41 ; KILLED))..((LA
cd30: 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 UNCHED REMOTEHOS
cd40: 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 TSTART RUNNING)
cd50: 20 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 28 63 .. (if (> (- (c
cd60: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
cd70: 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 + (db:test-get-e
cd80: 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 vent_time testda
cd90: 74 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 t)..... (d
cda0: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 b:test-get-run_d
cdb0: 75 72 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 uration testdat)
cdc0: 29 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 ))...600) ;; i.e
cdd0: 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 . no update for
cde0: 6d 6f 72 65 20 74 68 61 6e 20 36 30 30 20 73 65 more than 600 se
cdf0: 63 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 65 67 conds.. (beg
ce00: 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 in.. (debu
ce10: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
ce20: 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d NG: Test " test-
ce30: 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 name " appears t
ce40: 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 o be dead. Forci
ce50: 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 ng it to state I
ce60: 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 NCOMPLETE and st
ce70: 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 atus STUCK/DEAD"
ce80: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 73 ).. (tests
ce90: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 :test-set-status
cea0: 21 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d ! test-id "INCOM
ceb0: 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 PLETE" "STUCK/DE
cec0: 41 44 22 20 22 54 65 73 74 20 69 73 20 73 74 75 AD" "Test is stu
ced0: 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 29 ck or dead" #f))
cee0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
cef0: 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 int 2 "NOTE: " t
cf00: 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c est-name " is al
cf10: 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 ready running"))
cf20: 29 0a 09 28 65 6c 73 65 20 20 20 20 20 20 0a 09 )..(else ..
cf30: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
cf40: 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 "ERROR: Failed t
cf50: 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 o launch test "
cf60: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 full-test-name "
cf70: 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 . Unrecognised s
cf80: 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 65 74 tate " (test:get
cf90: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 -state testdat))
cfa0: 0a 09 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 .. (case (string
cfb0: 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 ->symbol (test:g
cfc0: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
cfd0: 29 29 20 0a 09 20 20 20 28 28 43 4f 4d 50 4c 45 )) .. ((COMPLE
cfe0: 54 45 44 20 49 4e 43 4f 4d 50 4c 45 54 45 29 0a TED INCOMPLETE).
cff0: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
d000: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
d010: 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 try (runs:make-f
d020: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
d030: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat
d040: 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 0a 09 h) 'DONOTRUN))..
d050: 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 28 68 (else.. (h
d060: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
d070: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 est-registry (ru
d080: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
d090: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name
d0a0: 20 74 65 73 74 2d 70 61 74 68 29 20 27 44 4f 4e test-path) 'DON
d0b0: 4f 54 52 55 4e 29 29 29 29 29 29 29 29 0a 0a 3b OTRUN))))))))..;
d0c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
d0d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d0e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d0f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d100: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f =======.;; END O
d110: 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d F NEW STUFF.;;==
d120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d160: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 ====..(define (g
d170: 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 et-dir-up-n dir
d180: 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 . params) . (le
d190: 74 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 t ((dparts (str
d1a0: 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f ing-split dir "/
d1b0: 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 "))..(count (i
d1c0: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
d1d0: 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 1 (car params))
d1e0: 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 )). (conc "/"
d1f0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
d200: 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 erse .. (t
d210: 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c ake dparts (- (l
d220: 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 63 6f ength dparts) co
d230: 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f unt)).. "/
d240: 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 "))))..(define (
d250: 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 runs:recursive-d
d260: 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 elete-with-error
d270: 2d 6d 73 67 20 72 65 61 6c 2d 64 69 72 29 0a 20 -msg real-dir).
d280: 20 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 (if (> (system
d290: 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 (conc "rm -rf "
d2a0: 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 20 20 real-dir)) 0).
d2b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
d2c0: 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 72 65 0 "ERROR: There
d2d0: 20 77 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 was a problem r
d2e0: 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 emoving " real-d
d2f0: 69 72 20 22 20 77 69 74 68 20 72 6d 20 2d 66 22 ir " with rm -f"
d300: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
d310: 6e 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d 74 ns:safe-delete-t
d320: 65 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 72 est-dir real-dir
d330: 29 0a 20 20 3b 3b 20 66 69 72 73 74 20 64 65 6c ). ;; first del
d340: 65 74 65 20 61 6c 6c 20 73 75 62 2d 64 69 72 65 ete all sub-dire
d350: 63 74 6f 72 69 65 73 0a 20 20 28 64 69 72 65 63 ctories. (direc
d360: 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 28 6c tory-fold . (l
d370: 61 6d 62 64 61 20 28 66 20 78 29 0a 20 20 20 20 ambda (f x).
d380: 20 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 6d 65 (let ((fullname
d390: 20 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 72 20 (conc real-dir
d3a0: 22 2f 22 20 66 29 29 29 0a 20 20 20 20 20 20 20 "/" f))).
d3b0: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
d3c0: 66 75 6c 6c 6e 61 6d 65 29 28 72 75 6e 73 3a 72 fullname)(runs:r
d3d0: 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d ecursive-delete-
d3e0: 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 66 with-error-msg f
d3f0: 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 ullname))).
d400: 28 2b 20 31 20 78 29 29 0a 20 20 20 30 20 72 65 (+ 1 x)). 0 re
d410: 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 68 65 al-dir). ;; the
d420: 6e 20 66 69 6c 65 73 20 6f 74 68 65 72 20 74 68 n files other th
d430: 61 6e 20 2a 74 65 73 74 64 61 74 2e 64 62 2a 0a an *testdat.db*.
d440: 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c (directory-fol
d450: 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 d . (lambda (f
d460: 20 78 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 x). (let ((
d470: 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 72 fullname (conc r
d480: 65 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 29 29 eal-dir "/" f)))
d490: 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
d4a0: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
d4b0: 28 72 65 67 65 78 70 20 22 74 65 73 74 64 61 74 (regexp "testdat
d4c0: 2e 64 62 22 29 20 66 29 29 0a 09 20 20 20 28 72 .db") f)).. (r
d4d0: 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 65 uns:recursive-de
d4e0: 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d lete-with-error-
d4f0: 6d 73 67 20 66 75 6c 6c 6e 61 6d 65 29 29 29 0a msg fullname))).
d500: 20 20 20 20 20 28 2b 20 31 20 78 29 29 0a 20 20 (+ 1 x)).
d510: 20 30 20 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b 0 real-dir). ;
d520: 3b 20 74 68 65 6e 20 74 68 65 20 65 6e 74 69 72 ; then the entir
d530: 65 20 64 69 72 65 63 74 6f 72 79 0a 20 20 28 72 e directory. (r
d540: 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 65 uns:recursive-de
d550: 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d lete-with-error-
d560: 6d 73 67 20 72 65 61 6c 2d 64 69 72 29 29 0a 0a msg real-dir))..
d570: 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b ;; Remove runs.;
d580: 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 ; fields are pas
d590: 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 sing in through
d5a0: 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 .;; action:.;;
d5b0: 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 'remove-runs.;
d5c0: 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d ; 'set-state-
d5d0: 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f status.;;.;; NB/
d5e0: 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e / should pass in
d5f0: 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e keys?.;;.(defin
d600: 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d e (runs:operate-
d610: 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 74 on action target
d620: 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 runnamepatt tes
d630: 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 tpatt #!key (sta
d640: 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 te #f)(status #f
d650: 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 )(new-state-stat
d660: 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d 6f us #f)). (commo
d670: 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 n:clear-caches)
d680: 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 ;; clear all cac
d690: 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 hes. (let* ((db
d6a0: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
d6b0: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 (keys (
d6c0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
d6d0: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
d6e0: 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 . (rundat
d6f0: 28 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d (mt:get-runs-by-
d700: 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d patt keys runnam
d710: 65 70 61 74 74 20 74 61 72 67 65 74 29 29 0a 09 epatt target))..
d720: 20 28 68 65 61 64 65 72 20 20 20 20 20 20 20 28 (header (
d730: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
d740: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
d750: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
d760: 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 f rundat 1)).. (
d770: 73 74 61 74 65 73 20 20 20 20 20 20 20 28 69 66 states (if
d780: 20 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d state (string-
d790: 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 split state ","
d7a0: 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 ) '())).. (statu
d7b0: 73 65 73 20 20 20 20 20 28 69 66 20 73 74 61 74 ses (if stat
d7c0: 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 us (string-split
d7d0: 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 status ",") '()
d7e0: 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 )).. (state-stat
d7f0: 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 us (if (string?
d800: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
d810: 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 ) (string-split
d820: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
d830: 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 ",") '(#f #f)))
d840: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
d850: 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
d860: 6f 70 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 operate-on => He
d870: 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 20 22 ader: " header "
d880: 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f action: " actio
d890: 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 n " new-state-st
d8a0: 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 atus: " new-stat
d8b0: 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 28 69 e-status). (i
d8c0: 66 20 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 73 f (> 2 (length s
d8d0: 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 28 tate-status))..(
d8e0: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
d8f0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
d900: 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 74 6f the parameter to
d910: 20 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 -set-state-stat
d920: 75 73 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 65 us is a comma de
d930: 6c 69 6d 69 74 65 64 20 73 74 72 69 6e 67 2e 20 limited string.
d940: 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c 46 E.g. COMPLETED,F
d950: 41 49 4c 22 29 0a 09 20 20 28 65 78 69 74 29 29 AIL").. (exit))
d960: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
d970: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 (lambda (ru
d980: 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 n). (let (
d990: 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d (runkey (string-
d9a0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
d9b0: 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 (lambda (k)....
d9c0: 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 ...(db:get-value
d9d0: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
d9e0: 65 61 64 65 72 20 6b 29 29 20 6b 65 79 73 29 20 eader k)) keys)
d9f0: 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 "/")).. (dir
da00: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b s-to-remove (mak
da10: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
da20: 20 20 20 20 20 28 70 72 6f 63 2d 67 65 74 2d 74 (proc-get-t
da30: 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 72 75 ests (lambda (ru
da40: 6e 2d 69 64 29 0a 09 09 09 20 20 20 20 20 20 28 n-id).... (
da50: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 mt:get-tests-for
da60: 2d 72 75 6e 20 72 75 6e 2d 69 64 0a 09 09 09 09 -run run-id.....
da70: 09 09 20 20 20 20 74 65 73 74 70 61 74 74 20 73 .. testpatt s
da80: 74 61 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 tates statuses..
da90: 09 09 09 09 09 20 20 20 20 6e 6f 74 2d 69 6e 3a ..... not-in:
daa0: 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 20 73 #f....... s
dab0: 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 61 63 ort-by: (case ac
dac0: 74 69 6f 6e 0a 09 09 09 09 09 09 09 20 20 20 20 tion........
dad0: 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 ((remove-runs
dae0: 29 20 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 ) 'rundir)......
daf0: 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 .. (else
db00: 20 20 20 20 20 20 20 20 27 65 76 65 6e 74 5f 74 'event_t
db10: 69 6d 65 29 29 29 29 29 29 0a 09 20 28 6c 65 74 ime)))))).. (let
db20: 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 28 64 * ((run-id (d
db30: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
db40: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
db50: 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 "id"))...(run-s
db60: 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 61 6c tate (db:get-val
db70: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
db80: 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 29 header "state")
db90: 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 20 28 )...(tests (
dba0: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
dbb0: 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 run-state "locke
dbc0: 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 d")).... (
dbd0: 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 72 proc-get-tests r
dbe0: 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 20 20 20 un-id)....
dbf0: 20 27 28 29 29 29 0a 09 09 28 6c 61 73 74 74 70 '()))...(lasttp
dc00: 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 ath "/does/not/e
dc10: 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a 09 xist/I/hope"))..
dc20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
dc30: 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 info 4 "runs:ope
dc40: 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 72 75 rate-on run=" ru
dc50: 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 n ", header=" he
dc60: 61 64 65 72 29 0a 09 20 20 20 28 69 66 20 28 6e ader).. (if (n
dc70: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 ot (null? tests)
dc80: 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ).. (begin
dc90: 0a 09 09 20 28 63 61 73 65 20 61 63 74 69 6f 6e ... (case action
dca0: 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 ... ((remove-r
dcb0: 75 6e 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 uns)... (debu
dcc0: 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 g:print 1 "Remov
dcd0: 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 ing tests for ru
dce0: 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
dcf0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
dd00: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
dd10: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a er "runname"))).
dd20: 09 09 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 .. ((set-state
dd30: 2d 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 -status)... (
dd40: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4d debug:print 1 "M
dd50: 6f 64 69 66 79 69 6e 67 20 73 74 61 74 65 20 61 odifying state a
dd60: 6e 64 20 73 74 61 75 73 20 66 6f 72 20 74 65 73 nd staus for tes
dd70: 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 ts for run: " ru
dd80: 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
dd90: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
dda0: 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
ddb0: 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 name")))... ((
ddc0: 70 72 69 6e 74 2d 72 75 6e 29 0a 09 09 20 20 20 print-run)...
ddd0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
dde0: 22 50 72 69 6e 74 69 6e 67 20 69 6e 66 6f 20 66 "Printing info f
ddf0: 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 20 or run " runkey
de00: 22 2c 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 ", run=" run ",
de10: 74 65 73 74 73 3d 22 20 74 65 73 74 73 20 22 2c tests=" tests ",
de20: 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 header=" header
de30: 29 0a 09 09 20 20 20 20 61 63 74 69 6f 6e 29 0a )... action).
de40: 09 09 20 20 20 28 28 72 75 6e 2d 77 61 69 74 29 .. ((run-wait)
de50: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
de60: 69 6e 74 20 31 20 22 57 61 69 74 69 6e 67 20 66 int 1 "Waiting f
de70: 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 20 or run " runkey
de80: 22 2c 20 72 75 6e 3d 22 20 72 75 6e 6e 61 6d 65 ", run=" runname
de90: 70 61 74 74 20 22 20 74 6f 20 63 6f 6d 70 6c 65 patt " to comple
dea0: 74 65 22 29 29 0a 09 09 20 20 20 28 65 6c 73 65 te"))... (else
deb0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
dec0: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 74 69 int-info 0 "acti
ded0: 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 on not recognise
dee0: 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 d " action)))...
def0: 20 28 6c 65 74 20 28 28 73 6f 72 74 65 64 2d 74 (let ((sorted-t
df00: 65 73 74 73 20 20 20 20 20 28 73 6f 72 74 20 74 ests (sort t
df10: 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 61 20 ests (lambda (a
df20: 62 29 28 6c 65 74 20 28 28 64 69 72 61 20 28 64 b)(let ((dira (d
df30: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
df40: 72 20 61 29 29 0a 09 09 09 09 09 09 09 09 09 28 r a))..........(
df50: 64 69 72 62 20 28 64 62 3a 74 65 73 74 2d 67 65 dirb (db:test-ge
df60: 74 2d 72 75 6e 64 69 72 20 62 29 29 29 0a 09 09 t-rundir b)))...
df70: 09 09 09 09 09 09 20 20 20 20 28 69 66 20 28 61 ...... (if (a
df80: 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 69 72 61 nd (string? dira
df90: 29 28 73 74 72 69 6e 67 3f 20 64 69 72 62 29 29 )(string? dirb))
dfa0: 0a 09 09 09 09 09 09 09 09 09 28 3e 20 28 73 74 ..........(> (st
dfb0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 ring-length dira
dfc0: 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 )(string-length
dfd0: 64 69 72 62 29 29 0a 09 09 09 09 09 09 09 09 09 dirb))..........
dfe0: 23 66 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 #f)))))...
dff0: 20 28 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d (test-retry-tim
e000: 65 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 e (make-hash-ta
e010: 62 6c 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 ble))... (
e020: 61 6c 6c 6f 77 2d 72 75 6e 2d 74 69 6d 65 20 20 allow-run-time
e030: 20 31 30 29 29 20 3b 3b 20 73 65 63 6f 6e 64 73 10)) ;; seconds
e040: 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 6b 69 to allow for ki
e050: 6c 6c 69 6e 67 20 74 65 73 74 73 20 62 65 66 6f lling tests befo
e060: 72 65 20 6a 75 73 74 20 62 72 75 74 61 6c 6c 79 re just brutally
e070: 20 6b 69 6c 6c 69 6e 67 20 27 65 6d 0a 09 09 20 killing 'em...
e080: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 (let loop ((te
e090: 73 74 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 st (car sorted-t
e0a0: 65 73 74 73 29 29 0a 09 09 09 20 20 20 20 20 20 ests))....
e0b0: 28 74 61 6c 20 20 28 63 64 72 20 73 6f 72 74 65 (tal (cdr sorte
e0c0: 64 2d 74 65 73 74 73 29 29 29 0a 09 09 20 20 20 d-tests)))...
e0d0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 69 (let* ((test-i
e0e0: 64 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 d (db:test
e0f0: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 0a 09 -get-id test))..
e100: 09 09 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d .. (new-test-
e110: 64 61 74 20 20 28 63 64 62 3a 67 65 74 2d 74 65 dat (cdb:get-te
e120: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 st-info-by-id *r
e130: 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 unremote* test-i
e140: 64 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 d)))... (i
e150: 66 20 28 6e 6f 74 20 6e 65 77 2d 74 65 73 74 2d f (not new-test-
e160: 64 61 74 29 0a 09 09 09 20 20 20 28 62 65 67 69 dat).... (begi
e170: 6e 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 n.... (debug
e180: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
e190: 20 57 65 20 68 61 76 65 20 61 20 74 65 73 74 2d We have a test-
e1a0: 69 64 20 6f 66 20 22 20 74 65 73 74 2d 69 64 20 id of " test-id
e1b0: 22 20 62 75 74 20 6e 6f 20 72 65 63 6f 72 64 20 " but no record
e1c0: 77 61 73 20 66 6f 75 6e 64 2e 20 4e 4f 54 45 3a was found. NOTE:
e1d0: 20 4e 6f 20 6c 6f 63 6b 69 6e 67 20 6f 66 20 72 No locking of r
e1e0: 65 63 6f 72 64 73 20 69 73 20 64 6f 6e 65 20 62 ecords is done b
e1f0: 65 74 77 65 65 6e 20 70 72 6f 63 65 73 73 65 73 etween processes
e200: 2c 20 64 6f 20 6e 6f 74 20 73 69 6d 75 6c 74 61 , do not simulta
e210: 6e 65 6f 75 73 6c 79 20 72 65 6d 6f 76 65 20 74 neously remove t
e220: 68 65 20 73 61 6d 65 20 72 75 6e 20 66 72 6f 6d he same run from
e230: 20 74 77 6f 20 70 72 6f 63 65 73 73 65 73 21 22 two processes!"
e240: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 6e ).... (if (n
e250: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
e260: 09 09 09 09 20 28 6c 6f 6f 70 20 28 63 61 72 20 .... (loop (car
e270: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
e280: 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 28 28 69 .... (let* ((i
e290: 74 65 6d 2d 70 61 74 68 20 20 20 20 20 28 64 62 tem-path (db
e2a0: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
e2b0: 61 74 68 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 ath new-test-dat
e2c0: 29 29 0a 09 09 09 09 20 20 28 74 65 73 74 2d 6e ))..... (test-n
e2d0: 61 6d 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 ame (db:test
e2e0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 6e 65 -get-testname ne
e2f0: 77 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 w-test-dat))....
e300: 09 20 20 28 72 75 6e 2d 64 69 72 20 20 20 20 20 . (run-dir
e310: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
e320: 75 6e 64 69 72 20 6e 65 77 2d 74 65 73 74 2d 64 undir new-test-d
e330: 61 74 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 64 at)) ;; run d
e340: 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 20 6c ir is from the l
e350: 69 6e 6b 20 74 72 65 65 0a 09 09 09 09 20 20 28 ink tree..... (
e360: 72 65 61 6c 2d 64 69 72 20 20 20 20 20 20 28 69 real-dir (i
e370: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
e380: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 09 20 run-dir).......
e390: 20 20 20 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 (resolve-pat
e3a0: 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 0a 09 hname run-dir)..
e3b0: 09 09 09 09 09 20 20 20 20 20 23 66 29 29 0a 09 ..... #f))..
e3c0: 09 09 09 20 20 28 74 65 73 74 2d 73 74 61 74 65 ... (test-state
e3d0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
e3e0: 2d 73 74 61 74 65 20 6e 65 77 2d 74 65 73 74 2d -state new-test-
e3f0: 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 65 73 dat))..... (tes
e400: 74 2d 66 75 6c 6c 6e 20 20 20 20 28 64 62 3a 74 t-fulln (db:t
e410: 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 6d 65 est-get-fullname
e420: 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 29 new-test-dat)))
e430: 0a 09 09 09 20 20 20 20 20 28 63 61 73 65 20 61 .... (case a
e440: 63 74 69 6f 6e 0a 09 09 09 20 20 20 20 20 20 20 ction....
e450: 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 ((remove-runs)..
e460: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
e470: 69 6e 66 6f 20 30 20 22 74 65 73 74 3a 20 22 20 info 0 "test: "
e480: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 74 65 73 test-name " ites
e490: 74 2d 73 74 61 74 65 3a 20 22 20 74 65 73 74 2d t-state: " test-
e4a0: 73 74 61 74 65 29 0a 09 09 09 09 28 69 66 20 28 state).....(if (
e4b0: 6d 65 6d 62 65 72 20 74 65 73 74 2d 73 74 61 74 member test-stat
e4c0: 65 20 28 6c 69 73 74 20 22 52 55 4e 4e 49 4e 47 e (list "RUNNING
e4d0: 22 20 22 4c 41 55 4e 43 48 45 44 22 20 22 52 45 " "LAUNCHED" "RE
e4e0: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 MOTEHOSTSTART" "
e4f0: 4b 49 4c 4c 52 45 51 22 29 29 0a 09 09 09 09 20 KILLREQ")).....
e500: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 (begin.....
e510: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
e520: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
e530: 61 75 6c 74 20 74 65 73 74 2d 72 65 74 72 79 2d ault test-retry-
e540: 74 69 6d 65 20 74 65 73 74 2d 66 75 6c 6c 6e 20 time test-fulln
e550: 23 66 29 29 0a 09 09 09 09 09 20 20 28 62 65 67 #f))...... (beg
e560: 69 6e 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 77 in...... ;; w
e570: 61 6e 74 20 74 6f 20 73 65 74 20 74 6f 20 52 45 ant to set to RE
e580: 4d 4f 56 49 4e 47 20 42 55 54 20 43 41 4e 4e 4f MOVING BUT CANNO
e590: 54 20 64 6f 20 69 74 20 68 65 72 65 3f 0a 09 09 T do it here?...
e5a0: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
e5b0: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 74 le-set! test-ret
e5c0: 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 6c ry-time test-ful
e5d0: 6c 6e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ln (current-seco
e5e0: 6e 64 73 29 29 29 29 0a 09 09 09 09 20 20 20 20 nds)))).....
e5f0: 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 (if (> (- (cur
e600: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 68 61 rent-seconds)(ha
e610: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
e620: 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 74 65 73 t-retry-time tes
e630: 74 2d 66 75 6c 6c 6e 29 29 20 61 6c 6c 6f 77 2d t-fulln)) allow-
e640: 72 75 6e 2d 74 69 6d 65 29 0a 09 09 09 09 09 20 run-time)......
e650: 20 3b 3b 20 54 68 69 73 20 74 65 73 74 20 69 73 ;; This test is
e660: 20 6e 6f 74 20 69 6e 20 61 20 63 6f 72 72 65 63 not in a correc
e670: 74 20 73 74 61 74 65 20 66 6f 72 20 63 6c 65 61 t state for clea
e680: 6e 69 6e 67 20 75 70 2e 20 4c 65 74 27 73 20 74 ning up. Let's t
e690: 72 79 20 73 6f 6d 65 20 67 72 61 63 65 66 75 6c ry some graceful
e6a0: 20 73 68 75 74 64 6f 77 6e 20 73 74 65 70 73 20 shutdown steps
e6b0: 66 69 72 73 74 0a 09 09 09 09 09 20 20 3b 3b 20 first...... ;;
e6c0: 53 65 74 20 74 68 65 20 74 65 73 74 20 74 6f 20 Set the test to
e6d0: 22 4b 49 4c 4c 52 45 51 22 20 61 6e 64 20 77 61 "KILLREQ" and wa
e6e0: 69 74 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 it five seconds
e6f0: 74 68 65 6e 20 74 72 79 20 61 67 61 69 6e 2e 20 then try again.
e700: 52 65 70 65 61 74 20 75 70 20 74 6f 20 66 69 76 Repeat up to fiv
e710: 65 20 74 69 6d 65 73 20 74 68 65 6e 20 67 69 76 e times then giv
e720: 65 0a 09 09 09 09 09 20 20 3b 3b 20 75 70 20 61 e...... ;; up a
e730: 6e 64 20 62 6c 6f 77 20 69 74 20 61 77 61 79 2e nd blow it away.
e740: 0a 09 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 ...... (begin..
e750: 09 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 .... (debug:p
e760: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
e770: 20 63 6f 75 6c 64 20 6e 6f 74 20 67 72 61 63 65 could not grace
e780: 66 75 6c 6c 79 20 72 65 6d 6f 76 65 20 74 65 73 fully remove tes
e790: 74 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e 20 22 t " test-fulln "
e7a0: 2c 20 74 72 69 65 64 20 74 6f 20 6b 69 6c 6c 20 , tried to kill
e7b0: 69 74 20 74 6f 20 6e 6f 20 61 76 61 69 6c 2e 20 it to no avail.
e7c0: 46 6f 72 63 69 6e 67 20 73 74 61 74 65 20 74 6f Forcing state to
e7d0: 20 46 41 49 4c 45 44 4b 49 4c 4c 20 61 6e 64 20 FAILEDKILL and
e7e0: 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 09 09 09 continuing")....
e7f0: 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 .. (mt:test-s
e800: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
e810: 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 by-id (db:test-g
e820: 65 74 2d 69 64 20 74 65 73 74 29 20 22 46 41 49 et-id test) "FAI
e830: 4c 45 44 4b 49 4c 4c 22 20 22 6e 2f 61 22 20 23 LEDKILL" "n/a" #
e840: 66 29 0a 09 09 09 09 09 20 20 20 20 28 74 68 72 f)...... (thr
e850: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a 09 ead-sleep! 1))..
e860: 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
e870: 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 .. (mt:test-s
e880: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
e890: 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 by-id (db:test-g
e8a0: 65 74 2d 69 64 20 74 65 73 74 29 20 22 4b 49 4c et-id test) "KIL
e8b0: 4c 52 45 51 22 20 22 6e 2f 61 22 20 23 66 29 0a LREQ" "n/a" #f).
e8c0: 09 09 09 09 09 20 20 20 20 28 74 68 72 65 61 64 ..... (thread
e8d0: 2d 73 6c 65 65 70 21 20 31 29 29 29 0a 09 09 09 -sleep! 1)))....
e8e0: 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 . ;; NOTE:
e8f0: 54 68 69 73 20 69 73 20 73 75 62 6f 70 74 69 6d This is suboptim
e900: 61 6c 20 61 73 20 74 68 65 20 74 65 73 74 64 61 al as the testda
e910: 74 61 20 77 69 6c 6c 20 62 65 20 75 73 65 64 20 ta will be used
e920: 6c 61 74 65 72 20 61 6e 64 20 74 68 65 20 73 74 later and the st
e930: 61 74 65 2f 73 74 61 74 75 73 20 6d 61 79 20 68 ate/status may h
e940: 61 76 65 20 63 68 61 6e 67 65 64 20 2e 2e 2e 0a ave changed ....
e950: 09 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6e .... (if (n
e960: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 09 20 ull? tal)......
e970: 20 28 6c 6f 6f 70 20 6e 65 77 2d 74 65 73 74 2d (loop new-test-
e980: 64 61 74 20 74 61 6c 29 0a 09 09 09 09 09 20 20 dat tal)......
e990: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
e9a0: 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 append tal (list
e9b0: 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 29 new-test-dat)))
e9c0: 29 29 0a 09 09 09 09 20 20 20 20 28 62 65 67 69 ))..... (begi
e9d0: 6e 0a 09 09 09 09 20 20 20 20 20 20 28 6d 74 3a n..... (mt:
e9e0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
e9f0: 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a tatus-by-id (db:
ea00: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
ea10: 29 20 22 52 45 4d 4f 56 49 4e 47 22 20 22 4c 4f ) "REMOVING" "LO
ea20: 43 4b 45 44 22 20 23 66 29 0a 09 09 09 09 20 20 CKED" #f).....
ea30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
ea40: 2d 69 6e 66 6f 20 31 20 22 41 74 74 65 6d 70 74 -info 1 "Attempt
ea50: 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 ing to remove "
ea60: 28 69 66 20 72 65 61 6c 2d 64 69 72 20 28 63 6f (if real-dir (co
ea70: 6e 63 20 22 20 64 69 72 20 22 20 72 65 61 6c 2d nc " dir " real-
ea80: 64 69 72 20 22 20 61 6e 64 20 22 29 20 22 22 29 dir " and ") "")
ea90: 20 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 " link " run-di
eaa0: 72 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 r)..... (if
eab0: 20 28 61 6e 64 20 72 65 61 6c 2d 64 69 72 20 0a (and real-dir .
eac0: 09 09 09 09 09 20 20 20 20 20 20 20 28 3e 20 28 ..... (> (
ead0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 string-length re
eae0: 61 6c 2d 64 69 72 29 20 35 29 0a 09 09 09 09 09 al-dir) 5)......
eaf0: 20 20 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 (file-exi
eb00: 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 29 20 sts? real-dir))
eb10: 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 63 ;; bad heuristic
eb20: 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 76 but should prev
eb30: 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 ent /tmp /home e
eb40: 74 63 2e 0a 09 09 09 09 09 20 20 28 62 65 67 69 tc....... (begi
eb50: 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 61 6c n ;; let* ((real
eb60: 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d 70 61 path (resolve-pa
eb70: 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 29 thname run-dir))
eb80: 29 0a 09 09 09 09 09 20 20 20 20 28 64 65 62 75 )...... (debu
eb90: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
eba0: 52 65 63 75 72 73 69 76 65 6c 79 20 72 65 6d 6f Recursively remo
ebb0: 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 29 ving " real-dir)
ebc0: 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 28 66 ...... (if (f
ebd0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c ile-exists? real
ebe0: 2d 64 69 72 29 0a 09 09 09 09 09 09 28 72 75 6e -dir).......(run
ebf0: 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d 74 65 s:safe-delete-te
ec00: 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 72 29 st-dir real-dir)
ec10: 0a 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 72 .......(debug:pr
ec20: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
ec30: 74 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d test dir " real-
ec40: 64 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f dir " appears to
ec50: 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 not exist or is
ec60: 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 not readable"))
ec70: 29 0a 09 09 09 09 09 20 20 28 69 66 20 72 65 61 )...... (if rea
ec80: 6c 2d 64 69 72 20 0a 09 09 09 09 09 20 20 20 20 l-dir ......
ec90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
eca0: 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 63 "WARNING: direc
ecb0: 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 72 20 tory " real-dir
ecc0: 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 " does not exist
ecd0: 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 ")...... (d
ece0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
ecf0: 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 64 RNING: no real d
ed00: 69 72 65 63 74 6f 72 79 20 63 6f 72 72 6f 73 70 irectory corrosp
ed10: 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 onding to link "
ed20: 20 72 75 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 68 run-dir ", noth
ed30: 69 6e 67 20 64 6f 6e 65 22 29 29 29 0a 09 09 09 ing done")))....
ed40: 09 20 20 20 20 20 20 28 69 66 20 28 73 79 6d 62 . (if (symb
ed50: 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 olic-link? run-d
ed60: 69 72 29 0a 09 09 09 09 09 20 20 28 62 65 67 69 ir)...... (begi
ed70: 6e 0a 09 09 09 09 09 20 20 20 20 28 64 65 62 75 n...... (debu
ed80: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
ed90: 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 6e 6b Removing symlink
eda0: 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 " run-dir).....
edb0: 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
edc0: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 20 eptions......
edd0: 20 20 65 78 6e 0a 09 09 09 09 09 20 20 20 20 20 exn......
ede0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
edf0: 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 ERROR: Failed t
ee00: 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 6e 6b o remove symlink
ee10: 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f 6e " run-dir ((con
ee20: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
ee30: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
ee40: 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 essage) exn) ",
ee50: 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6f attempting to co
ee60: 6e 74 69 6e 75 65 22 29 0a 09 09 09 09 09 20 20 ntinue")......
ee70: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 (delete-file
ee80: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 09 09 run-dir)))......
ee90: 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
eea0: 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 ? run-dir)......
eeb0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 64 69 (if (> (di
eec0: 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 rectory-fold (la
eed0: 6d 62 64 61 20 28 66 20 78 29 28 2b 20 31 20 78 mbda (f x)(+ 1 x
eee0: 29 29 20 30 20 72 75 6e 2d 64 69 72 29 20 30 29 )) 0 run-dir) 0)
eef0: 0a 09 09 09 09 09 09 20 20 28 64 65 62 75 67 3a ....... (debug:
ef00: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
ef10: 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 : refusing to re
ef20: 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 move " run-dir "
ef30: 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d as it is not em
ef40: 70 74 79 22 29 0a 09 09 09 09 09 09 20 20 28 68 pty")....... (h
ef50: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
ef60: 0a 09 09 09 09 09 09 20 20 20 65 78 6e 0a 09 09 ....... exn...
ef70: 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
ef80: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 int 0 "ERROR: F
ef90: 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 ailed to remove
efa0: 64 69 72 65 63 74 6f 72 79 20 22 20 72 75 6e 2d directory " run-
efb0: 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d dir ((condition-
efc0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
efd0: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
efe0: 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 exn) ", attempt
eff0: 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 ing to continue"
f000: 29 0a 09 09 09 09 09 09 20 20 20 28 64 65 6c 65 )....... (dele
f010: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e te-directory run
f020: 2d 64 69 72 29 29 29 0a 09 09 09 09 09 20 20 20 -dir)))......
f030: 20 20 20 28 69 66 20 72 75 6e 2d 64 69 72 0a 09 (if run-dir..
f040: 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
f050: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
f060: 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 not removing " r
f070: 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 un-dir " as it e
f080: 69 74 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 ither doesn't ex
f090: 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 ist or is not a
f0a0: 73 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 09 09 symlink").......
f0b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
f0c0: 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 "NOTE: the run
f0d0: 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 dir for this tes
f0e0: 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 t is undefined.
f0f0: 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c Test may have al
f100: 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 ready been delet
f110: 65 64 2e 22 29 29 0a 09 09 09 09 09 20 20 20 20 ed."))......
f120: 20 20 29 29 0a 09 09 09 09 20 20 20 20 20 20 3b ))..... ;
f130: 3b 20 4f 6e 6c 79 20 64 65 6c 65 74 65 20 74 68 ; Only delete th
f140: 65 20 72 65 63 6f 72 64 73 20 2a 61 66 74 65 72 e records *after
f150: 2a 20 72 65 6d 6f 76 69 6e 67 20 74 68 65 20 64 * removing the d
f160: 69 72 65 63 74 6f 72 79 2e 20 49 66 20 74 68 69 irectory. If thi
f170: 6e 67 73 20 66 61 69 6c 20 77 65 20 68 61 76 65 ngs fail we have
f180: 20 61 20 72 65 63 6f 72 64 20 0a 09 09 09 09 20 a record .....
f190: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
f1a0: 2d 72 75 6e 20 64 62 3a 64 65 6c 65 74 65 2d 74 -run db:delete-t
f1b0: 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 23 est-records db #
f1c0: 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 f (db:test-get-i
f1d0: 64 20 74 65 73 74 29 29 0a 09 09 09 09 20 20 20 d test)).....
f1e0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
f1f0: 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 09 20 20 l? tal))......
f200: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
f210: 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a 09 09 cdr tal))))))...
f220: 09 20 20 20 20 20 20 20 28 28 73 65 74 2d 73 74 . ((set-st
f230: 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 09 ate-status).....
f240: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
f250: 6f 20 32 20 22 6e 65 77 20 73 74 61 74 65 20 22 o 2 "new state "
f260: 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 (car state-stat
f270: 75 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 us) ", new statu
f280: 73 20 22 20 28 63 61 64 72 20 73 74 61 74 65 2d s " (cadr state-
f290: 73 74 61 74 75 73 29 29 0a 09 09 09 09 28 6d 74 status)).....(mt
f2a0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
f2b0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 status-by-id (db
f2c0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
f2d0: 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 t) (car state-st
f2e0: 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 65 atus)(cadr state
f2f0: 2d 73 74 61 74 75 73 29 20 23 66 29 0a 09 09 09 -status) #f)....
f300: 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f .(if (not (null?
f310: 20 74 61 6c 29 29 0a 09 09 09 09 20 20 20 20 28 tal))..... (
f320: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
f330: 64 72 20 74 61 6c 29 29 29 29 0a 09 09 09 20 20 dr tal))))....
f340: 20 20 20 20 20 28 28 72 75 6e 2d 77 61 69 74 29 ((run-wait)
f350: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
f360: 74 2d 69 6e 66 6f 20 32 20 22 73 74 69 6c 6c 20 t-info 2 "still
f370: 77 61 69 74 69 6e 67 2c 20 22 20 28 6c 65 6e 67 waiting, " (leng
f380: 74 68 20 74 65 73 74 73 29 20 22 20 74 65 73 74 th tests) " test
f390: 73 20 73 74 69 6c 6c 20 72 75 6e 6e 69 6e 67 22 s still running"
f3a0: 29 0a 09 09 09 09 28 74 68 72 65 61 64 2d 73 6c ).....(thread-sl
f3b0: 65 65 70 21 20 31 30 29 0a 09 09 09 09 28 6c 65 eep! 10).....(le
f3c0: 74 20 28 28 6e 65 77 2d 74 65 73 74 73 20 28 70 t ((new-tests (p
f3d0: 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 72 75 roc-get-tests ru
f3e0: 6e 2d 69 64 29 29 29 0a 09 09 09 09 20 20 28 69 n-id)))..... (i
f3f0: 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 2d 74 65 73 f (null? new-tes
f400: 74 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 ts)..... (d
f410: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
f420: 31 20 22 52 75 6e 20 63 6f 6d 70 6c 65 74 65 64 1 "Run completed
f430: 20 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 7a 65 according to ze
f440: 72 6f 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e ro tests matchin
f450: 67 20 70 72 6f 76 69 64 65 64 20 63 72 69 74 65 g provided crite
f460: 72 69 61 2e 22 29 0a 09 09 09 09 20 20 20 20 20 ria.").....
f470: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 2d (loop (car new-
f480: 74 65 73 74 73 29 28 63 64 72 20 6e 65 77 2d 74 tests)(cdr new-t
f490: 65 73 74 73 29 29 29 29 29 29 29 29 0a 09 09 20 ests))))))))...
f4a0: 20 20 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 )))))..
f4b0: 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 ;; remove the ru
f4c0: 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 n if zero tests
f4d0: 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 remain.. (if (
f4e0: 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f eq? action 'remo
f4f0: 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 ve-runs)..
f500: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
f510: 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (mt:get-tests-f
f520: 6f 72 2d 72 75 6e 20 28 64 62 3a 67 65 74 2d 76 or-run (db:get-v
f530: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
f540: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 20 un header "id")
f550: 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 20 #f '("DELETED")
f560: 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a '("n/a") not-in:
f570: 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 28 6e #t)))... (if (n
f580: 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 3b ull? remtests) ;
f590: 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 ; no more tests
f5a0: 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 remaining...
f5b0: 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 (let* ((dparts
f5c0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c (string-split l
f5d0: 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 asttpath "/"))..
f5e0: 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 28 .. (runpath (
f5f0: 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 conc "/" (string
f600: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 -intersperse ...
f610: 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 73 ....(take dparts
f620: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
f630: 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 2f ts) 1))......."/
f640: 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 "))))... (
f650: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
f660: 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 emoving run: " r
f670: 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 unkey " " (db:ge
f680: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
f690: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 r run header "ru
f6a0: 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 72 65 nname") " and re
f6b0: 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 0a 09 lated record")..
f6c0: 09 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d . (cdb:rem
f6d0: 6f 74 65 2d 72 75 6e 20 64 62 3a 64 65 6c 65 74 ote-run db:delet
f6e0: 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 e-run db run-id)
f6f0: 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 ... ;; Thi
f700: 73 20 69 73 20 61 20 70 72 65 74 74 79 20 67 6f s is a pretty go
f710: 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 67 od place to purg
f720: 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 65 e old DELETED te
f730: 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 63 64 sts... (cd
f740: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
f750: 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 delete-tests-for
f760: 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a -run db run-id).
f770: 09 09 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 .. (cdb:re
f780: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 64 65 6c 65 mote-run db:dele
f790: 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 te-old-deleted-t
f7a0: 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 0a est-records db).
f7b0: 09 09 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 .. (cdb:re
f7c0: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 73 65 74 2d mote-run db:set-
f7d0: 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 44 5f var db "DELETED_
f7e0: 54 45 53 54 53 22 20 28 63 75 72 72 65 6e 74 2d TESTS" (current-
f7f0: 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 seconds))...
f800: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 ;; need to fi
f810: 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 61 74 gure out the pat
f820: 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 69 72 h to the run dir
f830: 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 69 and remove it i
f840: 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 20 20 f empty...
f850: 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ;; (if (null
f860: 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 ? (glob (conc ru
f870: 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 npath "/*")))...
f880: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
f890: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
f8a0: 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 72 69 ;; . (debug:pri
f8b0: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 nt 1 "Removing r
f8c0: 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 74 68 un dir " runpath
f8d0: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 )... ;; .
f8e0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
f8f0: 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 61 74 mdir -p " runpat
f900: 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 h))))... )
f910: 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 72 )))).. )). r
f920: 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b 3d uns)). #t)..;;=
f930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f970: 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 =====.;; Routine
f980: 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 s for manipulati
f990: 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d ng runs.;;======
f9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9e0: 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 ..;; Since many
f9f0: 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 calls to a run r
fa00: 65 71 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 equire pretty mu
fa10: 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 ch the same setu
fa20: 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 p .;; this wrapp
fa30: 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 er is used to re
fa40: 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 duce the replica
fa50: 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 tion of code.(de
fa60: 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 fine (general-ru
fa70: 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d n-call switchnam
fa80: 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 e action-desc pr
fa90: 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e oc). (let ((run
faa0: 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 name (args:get-a
fab0: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a rg ":runname")).
fac0: 09 28 74 61 72 67 65 74 20 20 28 69 66 20 28 61 .(target (if (a
fad0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
fae0: 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 rget")... (a
faf0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
fb00: 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 rget")... (a
fb10: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
fb20: 71 74 61 72 67 22 29 29 29 29 0a 09 3b 3b 20 28 qtarg"))))..;; (
fb30: 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 20 20 th1 #f)).
fb40: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f (cond. ((no
fb50: 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 t target).
fb60: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
fb70: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 ERROR: Missing r
fb80: 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 equired paramete
fb90: 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 r for " switchna
fba0: 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 me ", you must s
fbb0: 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 65 pecify the targe
fbc0: 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 29 t with -target")
fbd0: 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 . (exit 3))
fbe0: 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e . ((not runn
fbf0: 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 ame). (debu
fc00: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
fc10: 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 : Missing requir
fc20: 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 ed parameter for
fc30: 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c " switchname ",
fc40: 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 you must specif
fc50: 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 y the run name w
fc60: 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 6e ith :runname run
fc70: 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 78 name"). (ex
fc80: 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c 73 it 3)). (els
fc90: 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 e. (let ((d
fca0: 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b 65 b #f).. (ke
fcb0: 79 73 20 23 66 29 0a 09 20 20 20 20 28 74 61 72 ys #f).. (tar
fcc0: 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 get (or (args:ge
fcd0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
fce0: 29 0a 09 09 09 28 61 72 67 73 3a 67 65 74 2d 61 )....(args:get-a
fcf0: 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 29 29 rg "-target"))))
fd00: 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 ..(if (not (setu
fd10: 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 p-for-run))..
fd20: 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 (begin ..
fd30: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
fd40: 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 2c Failed to setup,
fd50: 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 exiting")..
fd60: 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 3b 3b (exit 1)))..;;
fd70: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
fd80: 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 3b rg "-server")..;
fd90: 3b 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 ; (cdb:remot
fda0: 65 2d 72 75 6e 20 73 65 72 76 65 72 3a 73 74 61 e-run server:sta
fdb0: 72 74 20 64 62 20 28 61 72 67 73 3a 67 65 74 2d rt db (args:get-
fdc0: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 arg "-server")))
fdd0: 0a 09 28 73 65 74 21 20 6b 65 79 73 20 28 6b 65 ..(set! keys (ke
fde0: 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 ys:config-get-fi
fdf0: 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a elds *configdat*
fe00: 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 ))..;; have enou
fe10: 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 gh to process -t
fe20: 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 arget or -reqtar
fe30: 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 g here..(if (arg
fe40: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
fe50: 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a arg").. (let*
fe60: 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 ((runconfigf (c
fe70: 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 onc *toppath* "
fe80: 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
fe90: 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 ig")) ;; DO NOT
fea0: 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 EVALUATE ALL ...
feb0: 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 (runconfig (
fec0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 read-config runc
fed0: 6f 6e 66 69 67 66 20 23 66 20 23 74 20 65 6e 76 onfigf #f #t env
fee0: 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 iron-patt: #f)))
fef0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 .. (if (has
ff00: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
ff10: 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 ult runconfig (a
ff20: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
ff30: 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 qtarg") #f)...
ff40: 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 (keys:target-set
ff50: 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 -args keys (args
ff60: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
ff70: 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 rg") args:arg-ha
ff80: 73 68 29 0a 09 09 20 20 20 20 0a 09 09 20 20 28 sh)... ... (
ff90: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 begin... (deb
ffa0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
ffb0: 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d R: [" (args:get-
ffc0: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
ffd0: 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 "] not found in
ffe0: 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 " runconfigf)...
fff0: 20 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 (if db (sqli
10000 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
10010 29 29 0a 09 09 20 20 20 20 28 65 78 69 74 20 31 ))... (exit 1
10020 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 )))).. (if (a
10030 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
10040 72 67 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 rget")...(keys:t
10050 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b arget-set-args k
10060 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 eys (args:get-ar
10070 67 20 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 g "-target" args
10080 3a 61 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a :arg-hash) args:
10090 61 72 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 arg-hash)))..(if
100a0 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 (not (car *conf
100b0 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 iginfo*)).. (
100c0 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
100d0 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
100e0 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 20 74 6f OR: Attempted to
100f0 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 " action-desc "
10100 20 62 75 74 20 72 75 6e 20 61 72 65 61 20 63 6f but run area co
10110 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f nfig file not fo
10120 75 6e 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 und").. (ex
10130 69 74 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 it 1)).. ;; E
10140 78 74 72 61 63 74 20 6f 75 74 20 73 74 75 66 66 xtract out stuff
10150 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 needed in most
10160 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 or many calls..
10170 20 20 20 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 ;; here then
10180 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 call proc.. (
10190 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 let* ((keyvals
101a0 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e (keys:target->
101b0 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 keyval keys targ
101c0 65 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 et))).. (pr
101d0 6f 63 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d oc target runnam
101e0 65 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 29 29 e keys keyvals))
101f0 29 0a 09 28 69 66 20 64 62 20 28 73 71 6c 69 74 )..(if db (sqlit
10200 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
10210 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d )..(set! *didsom
10220 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 29 ething* #t))))))
10230 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
10240 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10250 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10260 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10270 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f ==========.;; Lo
10280 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b ck/unlock runs.;
10290 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
102a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102d0 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
102e0 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f (runs:handle-lo
102f0 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b 65 79 cking target key
10300 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 s runname lock u
10310 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 6c nlock user). (l
10320 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 23 et* ((db #
10330 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 28 f).. (rundat (
10340 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 mt:get-runs-by-p
10350 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 att keys runname
10360 20 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 target)).. (hea
10370 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 der (vector-re
10380 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 f rundat 0)).. (
10390 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 runs (vector
103a0 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 -ref rundat 1)))
103b0 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
103c0 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 lambda (run)...(
103d0 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 let ((run-id (db
103e0 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
103f0 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
10400 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 "id")))... (if
10410 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 (or lock.... (a
10420 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 nd unlock....
10430 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 (begin.....
10440 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 (print "Do you r
10450 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e eally wish to un
10460 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 lock run " run-i
10470 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 d "?\n y/n: ")
10480 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 ..... (equal? "y
10490 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 " (read-line))))
104a0 29 0a 09 09 20 20 20 20 20 20 28 63 64 62 3a 72 )... (cdb:r
104b0 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 6c 6f 63 emote-run db:loc
104c0 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 k/unlock-run db
104d0 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
104e0 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 ck user)...
104f0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
10500 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 6c fo 0 "Skipping l
10510 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 ock/unlock on "
10520 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 20 run-id))))..
10530 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d runs))).;;====
10540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10550 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10560 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10570 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10580 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e ==.;; Rollup run
10590 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
105a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 ==========..;; U
105e0 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f 6d pdate the test_m
105f0 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 68 eta table for th
10600 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 is test.(define
10610 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
10620 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 t_meta test-name
10630 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c test-conf). (l
10640 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 et ((currrecord
10650 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
10660 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d db:testmeta-get-
10670 72 65 63 6f 72 64 20 23 66 20 74 65 73 74 2d 6e record #f test-n
10680 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 ame))). (if (
10690 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 0a not currrecord).
106a0 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 .(begin.. (set!
106b0 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 6b currrecord (mak
106c0 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 29 e-vector 10 #f))
106d0 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d .. (cdb:remote-
106e0 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d run db:testmeta-
106f0 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 74 65 add-record #f te
10700 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
10710 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
10720 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 lambda (key).
10730 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 20 (let* ((idx
10740 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 20 (cadr key))..
10750 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b 65 (fld (car ke
10760 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c 20 y)).. (val
10770 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
10780 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d est-conf "test_m
10790 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 3b 3b eta" fld))).. ;;
107a0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
107b0 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 66 6c "idx: " idx " fl
107c0 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c 3a 20 d: " fld " val:
107d0 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 61 6e " val).. (if (an
107e0 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 d val (not (equa
107f0 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 l? (vector-ref c
10800 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 76 urrrecord idx) v
10810 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 al))).. (beg
10820 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e in.. (prin
10830 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 65 t "Updating " te
10840 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 st-name " " fld
10850 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 " to " val)..
10860 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
10870 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d run db:testmeta-
10880 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 66 20 update-field #f
10890 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 test-name fld va
108a0 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 22 l))))). '(("
108b0 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 author" 2)("owne
108c0 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 69 r" 3)("descripti
108d0 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 64 on" 4)("reviewed
108e0 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 29 " 5)("tags" 9)))
108f0 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 ))..;; Update te
10900 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 st_meta for all
10910 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 72 tests.(define (r
10920 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 uns:update-all-t
10930 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 est_meta db). (
10940 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 let ((test-names
10950 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 (tests:get-vali
10960 64 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 d-tests))). (
10970 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
10980 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d lambda (test-nam
10990 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 e). (let*
109a0 28 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 ((test-conf (
109b0 6d 74 3a 6c 61 7a 79 2d 72 65 61 64 2d 74 65 73 mt:lazy-read-tes
109c0 74 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 t-config test-na
109d0 6d 65 29 29 29 0a 09 20 3b 3b 20 75 73 65 20 74 me))).. ;; use t
109e0 68 65 20 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 he cdb:remote-ru
109f0 6e 20 69 6e 73 74 65 61 64 20 6f 66 20 70 61 73 n instead of pas
10a00 73 69 6e 67 20 69 6e 20 64 62 0a 09 20 28 69 66 sing in db.. (if
10a10 20 74 65 73 74 2d 63 6f 6e 66 20 28 72 75 6e 73 test-conf (runs
10a20 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
10a30 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 a test-name test
10a40 2d 63 6f 6e 66 29 29 29 29 0a 20 20 20 20 20 74 -conf)))). t
10a50 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b est-names)))..;;
10a60 20 54 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 This could prob
10a70 61 62 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 ably be refactor
10a80 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 ed into one comp
10a90 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 lex query ....(d
10aa0 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c efine (runs:roll
10ab0 75 70 2d 72 75 6e 20 6b 65 79 73 20 72 75 6e 6e up-run keys runn
10ac0 61 6d 65 20 75 73 65 72 20 6b 65 79 76 61 6c 73 ame user keyvals
10ad0 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
10ae0 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 4 "runs:rollup-
10af0 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 run, keys: " key
10b00 73 20 22 20 3a 72 75 6e 6e 61 6d 65 20 22 20 72 s " :runname " r
10b10 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 3a 20 22 unname " user: "
10b20 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 user). (let* (
10b30 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 (db
10b40 20 23 66 29 0a 09 20 28 6e 65 77 2d 72 75 6e 2d #f).. (new-run-
10b50 69 64 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d id (cdb:rem
10b60 6f 74 65 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 ote-run db:regis
10b70 74 65 72 2d 72 75 6e 20 23 66 20 6b 65 79 76 61 ter-run #f keyva
10b80 6c 73 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 ls runname "new"
10b90 20 22 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 20 "n/a" user))..
10ba0 28 70 72 65 76 2d 74 65 73 74 73 20 20 20 20 20 (prev-tests
10bb0 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
10bc0 20 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 test:get-matchi
10bd0 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
10be0 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 -run-records db
10bf0 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 new-run-id "%" "
10c00 25 22 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 %")).. (curr-tes
10c10 74 73 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d ts (mt:get-
10c20 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e 65 tests-for-run ne
10c30 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 27 w-run-id "%/%" '
10c40 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 72 72 () '())).. (curr
10c50 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d 61 6b -tests-hash (mak
10c60 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
10c70 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
10c80 72 75 6e 20 64 62 3a 75 70 64 61 74 65 2d 72 75 run db:update-ru
10c90 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 n-event_time db
10ca0 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 new-run-id).
10cb0 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c 72 ;; index the alr
10cc0 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 73 eady saved tests
10cd0 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 by testname and
10ce0 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 72 itemdat in curr
10cf0 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 20 -tests-hash.
10d00 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
10d10 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
10d20 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
10d30 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 testname (db:te
10d40 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
10d50 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
10d60 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
10d70 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
10d80 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 th testdat))..
10d90 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
10da0 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
10db0 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
10dc0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
10dd0 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 ! curr-tests-has
10de0 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 h full-name test
10df0 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 72 dat))). curr
10e00 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e -tests). ;; N
10e10 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c OPE: Non-optimal
10e20 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 74 approach. Try t
10e30 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 his instead..
10e40 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 61 ;; 1. tests a
10e50 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 61 re received in a
10e60 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 list, most rece
10e70 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 nt first. ;;
10e80 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 65 2. replace the
10e90 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 74 rollup test wit
10ea0 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 h the new *alway
10eb0 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s*. (for-each
10ec0 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
10ed0 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
10ee0 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
10ef0 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 (db:test-get-t
10f00 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
10f10 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
10f20 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
10f30 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 -item-path testd
10f40 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c at)).. (ful
10f50 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 l-name (conc tes
10f60 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
10f70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 72 ath)).. (pr
10f80 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 73 ev-test-dat (has
10f90 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
10fa0 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d 68 ult curr-tests-h
10fb0 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 ash full-name #f
10fc0 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
10fd0 73 74 65 70 73 20 20 20 20 28 63 64 62 3a 72 65 steps (cdb:re
10fe0 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
10ff0 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 steps-for-test d
11000 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 b (db:test-get-i
11010 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
11020 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 (new-test-re
11030 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 cord #f)).. ;; r
11040 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 eplace these wit
11050 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c h insert ... sel
11060 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c ect.. (apply sql
11070 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 ite3:execute ...
11080 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 db ...(conc "INS
11090 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
110a0 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 NTO tests (run_i
110b0 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 d,testname,state
110c0 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
110d0 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c me,host,cpuload,
110e0 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 diskfree,uname,r
110f0 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c undir,item_path,
11100 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e run_duration,fin
11110 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 al_logf,comment)
11120 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 "... "VALU
11130 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ES (?,?,?,?,?,?,
11140 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 ?,?,?,?,?,?,?,?)
11150 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 ;")...new-run-id
11160 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e (cddr (vector->
11170 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a list testdat))).
11180 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 . (set! new-test
11190 64 61 74 20 28 63 61 72 20 28 6d 74 3a 67 65 74 dat (car (mt:get
111a0 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e -tests-for-run n
111b0 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 ew-run-id (conc
111c0 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
111d0 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 29 m-path) '() '())
111e0 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 )).. (hash-table
111f0 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 -set! curr-tests
11200 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
11210 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 new-testdat) ;;
11220 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f this could be co
11230 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 nfusing, which r
11240 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 ecord should go
11250 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 into the lookup
11260 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 table?.. ;; Now
11270 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
11280 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 st steps.. (debu
11290 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
112a0 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
112b0 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 st_steps from te
112c0 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
112d0 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
112e0 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
112f0 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
11300 64 61 74 29 29 0a 09 20 28 63 64 62 3a 72 65 6d dat)).. (cdb:rem
11310 6f 74 65 2d 72 75 6e 20 0a 09 20 20 28 6c 61 6d ote-run .. (lam
11320 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c bda ().. (sql
11330 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
11340 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 db .. (c
11350 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
11360 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
11370 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c _steps (test_id,
11380 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 stepname,state,s
11390 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
113a0 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
113b0 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 "SELECT " (db:t
113c0 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
113d0 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 estdat) ",stepna
113e0 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
113f0 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 event_time,comme
11400 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 nt FROM test_ste
11410 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 ps WHERE test_id
11420 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a =?;").. (db:
11430 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
11440 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f dat)).. ;; No
11450 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
11460 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 test data.. (
11470 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 debug:print 4 "C
11480 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 opying records i
11490 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d n test_data from
114a0 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 test_id=" (db:t
114b0 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
114c0 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 at) " to " (db:t
114d0 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
114e0 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 estdat)).. (s
114f0 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
11500 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 . db ..
11510 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
11520 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
11530 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 st_data (test_id
11540 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
11550 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
11560 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
11570 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
11580 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
11590 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
115a0 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 t) ",category,va
115b0 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
115c0 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
115d0 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
115e0 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 73 t_data WHERE tes
115f0 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 t_id=?;")..
11600 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
11610 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 testdat)))).. ))
11620 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 . prev-tests
11630 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ))).. . .