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 69 " val). (i
1150: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 f (and (string?
1160: 6b 65 79 29 0a 09 09 28 73 74 72 69 6e 67 3f 20 key)...(string?
1170: 76 61 6c 29 29 0a 09 20 20 20 28 73 65 74 65 6e val)).. (seten
1180: 76 20 6b 65 79 20 76 61 6c 29 0a 09 20 20 20 28 v key val).. (
1190: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
11a0: 52 52 4f 52 3a 20 4d 61 6c 66 6f 72 6d 65 64 20 RROR: Malformed
11b0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 69 environment vari
11c0: 61 62 6c 65 20 64 65 66 69 6e 69 74 69 6f 6e 3a able definition:
11d0: 20 76 61 72 3d 22 20 76 61 72 20 22 2c 20 76 61 var=" var ", va
11e0: 6c 3d 22 20 76 61 6c 29 29 29 29 0a 20 20 20 20 l=" val)))).
11f0: 28 69 66 20 28 6e 6f 74 20 28 67 65 74 2d 65 6e (if (not (get-en
1200: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
1210: 6c 65 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 le "MT_TARGET"))
1220: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 (setenv "MT_TARG
1230: 45 54 22 20 74 61 72 67 65 74 29 29 0a 20 20 20 ET" target)).
1240: 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 (alist->env-var
1250: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 s (hash-table-re
1260: 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 f/default *confi
1270: 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 gdat* "env-overr
1280: 69 64 65 22 20 27 28 29 29 29 0a 20 20 20 20 3b ide" '())). ;
1290: 3b 20 4c 65 74 73 20 75 73 65 20 74 68 69 73 20 ; Lets use this
12a0: 61 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 74 as an opportunit
12b0: 79 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e 4e y to put MT_RUNN
12c0: 41 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 69 72 AME in the envir
12d0: 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 73 65 74 65 onment. (sete
12e0: 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 nv "MT_RUNNAME"
12f0: 28 69 66 20 69 6e 72 75 6e 6e 61 6d 65 20 69 6e (if inrunname in
1300: 72 75 6e 6e 61 6d 65 20 28 63 64 62 3a 72 65 6d runname (cdb:rem
1310: 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 ote-run db:get-r
1320: 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 un-name-from-id
1330: 23 66 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 #f run-id))).
1340: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
1350: 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 _AREA_HOME" *top
1360: 70 61 74 68 2a 29 29 29 0a 0a 28 64 65 66 69 6e path*)))..(defin
1370: 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d e (set-item-env-
1380: 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 20 vars itemdat).
1390: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
13a0: 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 20 a (item)..
13b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
13c0: 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 74 setenv " (car it
13d0: 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 74 em) " " (cadr it
13e0: 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 em)).. (set
13f0: 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 28 env (car item) (
1400: 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 20 cadr item)))..
1410: 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 3b 3b 20 itemdat))..;;
1420: 45 76 65 72 79 20 74 69 6d 65 20 63 61 6e 2d 72 Every time can-r
1430: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 69 73 un-more-tests is
1440: 20 63 61 6c 6c 65 64 20 69 6e 63 72 65 6d 65 6e called incremen
1450: 74 20 74 68 65 20 64 65 6c 61 79 0a 3b 3b 0a 3b t the delay.;;.;
1460: 3b 20 4e 4f 54 45 3a 20 57 65 20 72 75 6e 20 74 ; NOTE: We run t
1470: 68 69 73 20 73 65 72 76 65 72 2d 73 69 64 65 21 his server-side!
1480: 21 20 44 6f 20 6e 6f 74 20 75 73 65 20 74 68 69 ! Do not use thi
1490: 73 20 67 6c 6f 62 61 6c 20 65 78 63 65 70 74 20 s global except
14a0: 69 6e 20 74 68 65 20 72 75 6e 73 3a 63 61 6e 2d in the runs:can-
14b0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 run-more-tests r
14c0: 6f 75 74 69 6e 65 0a 3b 3b 0a 28 64 65 66 69 6e outine.;;.(defin
14d0: 65 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e e *last-num-runn
14e0: 69 6e 67 2d 74 65 73 74 73 2a 20 30 29 0a 28 64 ing-tests* 0).(d
14f0: 65 66 69 6e 65 20 2a 72 75 6e 73 3a 63 61 6e 2d efine *runs:can-
1500: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1510: 6f 75 6e 74 2a 20 30 29 0a 28 64 65 66 69 6e 65 ount* 0).(define
1520: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
1530: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
1540: 2d 63 6f 75 6e 74 29 20 3b 3b 20 74 68 65 20 64 -count) ;; the d
1550: 62 20 69 73 20 61 20 64 75 6d 6d 79 20 76 61 72 b is a dummy var
1560: 20 73 6f 20 77 65 20 63 61 6e 20 75 73 65 20 63 so we can use c
1570: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 0a 20 20 db:remote-run.
1580: 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d (set! *runs:can-
1590: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
15a0: 6f 75 6e 74 2a 20 30 29 29 20 3b 3b 20 28 2f 20 ount* 0)) ;; (/
15b0: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
15c0: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
15d0: 32 29 29 29 0a 0a 3b 3b 20 54 65 6d 70 6f 72 61 2)))..;; Tempora
15e0: 72 79 20 67 6c 6f 62 61 6c 73 2e 20 4d 6f 76 65 ry globals. Move
15f0: 20 74 68 65 73 65 20 69 6e 74 6f 20 74 68 65 20 these into the
1600: 6c 6f 67 69 63 20 6f 72 20 69 6e 74 6f 20 63 6f logic or into co
1610: 6d 6d 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 mmon.;;.(define
1620: 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 *seen-cant-run-t
1630: 65 73 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 ests* (make-hash
1640: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 75 73 65 20 -table)) ;; use
1650: 74 6f 20 74 72 61 63 6b 20 74 65 73 74 73 20 74 to track tests t
1660: 68 61 74 20 77 65 20 73 75 73 70 65 63 74 20 63 hat we suspect c
1670: 61 6e 6e 6f 74 20 62 65 20 72 75 6e 0a 28 64 65 annot be run.(de
1680: 66 69 6e 65 20 28 72 75 6e 73 3a 69 6e 63 2d 63 fine (runs:inc-c
1690: 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 20 74 65 ant-run-tests te
16a0: 73 74 6e 61 6d 65 29 0a 20 20 28 68 61 73 68 2d stname). (hash-
16b0: 74 61 62 6c 65 2d 73 65 74 21 20 2a 73 65 65 6e table-set! *seen
16c0: 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a -cant-run-tests*
16d0: 20 74 65 73 74 6e 61 6d 65 0a 09 09 20 20 20 28 testname... (
16e0: 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 + (hash-table-re
16f0: 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e 2d f/default *seen-
1700: 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 cant-run-tests*
1710: 74 65 73 74 6e 61 6d 65 20 30 29 20 31 29 29 29 testname 0) 1)))
1720: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 .(define (runs:c
1730: 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 3f an-keep-running?
1740: 20 74 65 73 74 6e 61 6d 65 20 6e 29 0a 20 20 28 testname n). (
1750: 3c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 < (hash-table-re
1760: 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e 2d f/default *seen-
1770: 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a 20 cant-run-tests*
1780: 74 65 73 74 6e 61 6d 65 20 30 29 20 6e 29 29 0a testname 0) n)).
1790: 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 3a 64 .(define *runs:d
17a0: 65 6e 6f 69 73 65 2a 20 28 6d 61 6b 65 2d 68 61 enoise* (make-ha
17b0: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 6b 65 sh-table)) ;; ke
17c0: 79 20 3d 3e 20 6c 61 73 74 2d 74 69 6d 65 2d 72 y => last-time-r
17d0: 61 6e 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e an..(define (run
17e0: 73 3a 6c 6f 77 6e 6f 69 73 65 20 6b 65 79 20 77 s:lownoise key w
17f0: 61 69 74 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 aitval). (let (
1800: 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d (lasttime (hash-
1810: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1820: 74 20 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 65 2a t *runs:denoise*
1830: 20 6b 65 79 20 30 29 29 0a 09 28 63 75 72 72 74 key 0))..(currt
1840: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
1850: 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 onds))). (if
1860: 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 20 6c (> (- currtime l
1870: 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 61 6c asttime) waitval
1880: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 68 61 )..(begin.. (ha
1890: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 72 sh-table-set! *r
18a0: 75 6e 73 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 79 uns:denoise* key
18b0: 20 63 75 72 72 74 69 6d 65 29 0a 09 20 20 23 74 currtime).. #t
18c0: 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e )..#f)))..(defin
18d0: 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d e (runs:can-run-
18e0: 6d 6f 72 65 2d 74 65 73 74 73 20 6a 6f 62 67 72 more-tests jobgr
18f0: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
1900: 6e 74 2d 6a 6f 62 73 29 0a 20 20 28 74 68 72 65 nt-jobs). (thre
1910: 61 64 2d 73 6c 65 65 70 21 20 28 63 6f 6e 64 0a ad-sleep! (cond.
1920: 09 09 20 20 28 28 3e 20 2a 72 75 6e 73 3a 63 61 .. ((> *runs:ca
1930: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
1940: 2d 63 6f 75 6e 74 2a 20 32 30 29 20 32 29 3b 3b -count* 20) 2);;
1950: 20 6f 62 76 69 6f 75 73 6c 79 20 68 61 76 65 6e obviously haven
1960: 27 74 20 68 61 64 20 61 6e 79 20 77 6f 72 6b 20 't had any work
1970: 74 6f 20 64 6f 20 66 6f 72 20 61 20 77 68 69 6c to do for a whil
1980: 65 0a 09 09 20 20 28 65 6c 73 65 20 30 29 29 29 e... (else 0)))
1990: 0a 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 2d 72 . (let* ((num-r
19a0: 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 unning
19b0: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
19c0: 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d un db:get-count-
19d0: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 23 66 tests-running #f
19e0: 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e )).. (num-runnin
19f0: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 63 g-in-jobgroup (c
1a00: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
1a10: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
1a20: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1a30: 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 6f 75 70 roup #f jobgroup
1a40: 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 2d )).. (job-group-
1a50: 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 6c limit (l
1a60: 65 74 20 28 28 6a 6f 62 67 2d 63 6f 75 6e 74 20 et ((jobg-count
1a70: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a (config-lookup *
1a80: 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 configdat* "jobg
1a90: 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 roups" jobgroup)
1aa0: 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 ))..... (if (
1ab0: 73 74 72 69 6e 67 3f 20 6a 6f 62 67 2d 63 6f 75 string? jobg-cou
1ac0: 6e 74 29 0a 09 09 09 09 09 28 73 74 72 69 6e 67 nt)......(string
1ad0: 2d 3e 6e 75 6d 62 65 72 20 6a 6f 62 67 2d 63 6f ->number jobg-co
1ae0: 75 6e 74 29 0a 09 09 09 09 09 6a 6f 62 67 2d 63 unt)......jobg-c
1af0: 6f 75 6e 74 29 29 29 29 0a 20 20 20 20 28 69 66 ount)))). (if
1b00: 20 28 3e 20 28 2b 20 6e 75 6d 2d 72 75 6e 6e 69 (> (+ num-runni
1b10: 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 ng num-running-i
1b20: 6e 2d 6a 6f 62 67 72 6f 75 70 29 20 30 29 0a 09 n-jobgroup) 0)..
1b30: 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d (set! *runs:can-
1b40: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1b50: 6f 75 6e 74 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 ount* (+ *runs:c
1b60: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
1b70: 73 2d 63 6f 75 6e 74 2a 20 31 29 29 29 0a 20 20 s-count* 1))).
1b80: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
1b90: 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e *last-num-runnin
1ba0: 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e g-tests* num-run
1bb0: 6e 69 6e 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 ning))..(begin..
1bc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
1bd0: 20 22 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 "max-concurrent
1be0: 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e -jobs: " max-con
1bf0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 current-jobs ",
1c00: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e num-running: " n
1c10: 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 um-running).. (
1c20: 73 65 74 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 set! *last-num-r
1c30: 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 unning-tests* nu
1c40: 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 m-running))).
1c50: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 (if (not (eq? 0
1c60: 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 *globalexitstat
1c70: 75 73 2a 29 29 0a 09 28 6c 69 73 74 20 23 66 20 us*))..(list #f
1c80: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d num-running num-
1c90: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
1ca0: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
1cb0: 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 nt-jobs job-grou
1cc0: 70 2d 6c 69 6d 69 74 29 0a 09 28 6c 65 74 20 28 p-limit)..(let (
1cd0: 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 (can-not-run-mor
1ce0: 65 20 28 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 e (cond..... ;;
1cf0: 69 66 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e if max-concurren
1d00: 74 2d 6a 6f 62 73 20 69 73 20 73 65 74 20 61 6e t-jobs is set an
1d10: 64 20 74 68 65 20 6e 75 6d 62 65 72 20 72 75 6e d the number run
1d20: 6e 69 6e 67 20 69 73 20 67 72 65 61 74 65 72 20 ning is greater
1d30: 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 ..... ;; than it
1d40: 20 74 68 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e than cannot run
1d50: 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 more jobs.....
1d60: 28 28 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 ((and max-concur
1d70: 72 65 6e 74 2d 6a 6f 62 73 20 28 3e 3d 20 6e 75 rent-jobs (>= nu
1d80: 6d 2d 72 75 6e 6e 69 6e 67 20 6d 61 78 2d 63 6f m-running max-co
1d90: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a ncurrent-jobs)).
1da0: 09 09 09 09 20 20 28 69 66 20 28 72 75 6e 73 3a .... (if (runs:
1db0: 6c 6f 77 6e 6f 69 73 65 20 22 6d 63 6a 20 6d 73 lownoise "mcj ms
1dc0: 67 22 20 36 30 29 0a 09 09 09 09 20 20 20 20 20 g" 60).....
1dd0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
1de0: 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 "WARNING: Max ru
1df0: 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 nning jobs excee
1e00: 64 65 64 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d ded, current num
1e10: 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e ber running: " n
1e20: 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 um-running .....
1e30: 09 09 20 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 .. ", max_conc
1e40: 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d urrent_jobs: " m
1e50: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1e60: 62 73 29 29 0a 09 09 09 09 20 20 23 74 29 0a 09 bs))..... #t)..
1e70: 09 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 ... ;; if job-gr
1e80: 6f 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 oup-limit is set
1e90: 20 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a and number of j
1ea0: 6f 62 73 20 69 6e 20 74 68 65 20 67 72 6f 75 70 obs in the group
1eb0: 20 69 73 20 67 72 65 61 74 65 72 0a 09 09 09 09 is greater.....
1ec0: 20 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 6d ;; than the lim
1ed0: 69 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 it then cannot r
1ee0: 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 un more jobs of
1ef0: 74 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 this kind..... (
1f00: 28 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c (and job-group-l
1f10: 69 6d 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 imit.....
1f20: 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d (>= num-running-
1f30: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d in-jobgroup job-
1f40: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 group-limit))...
1f50: 09 09 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f .. (if (runs:lo
1f60: 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 6d 61 wnoise (conc "ma
1f70: 78 6a 6f 62 67 72 6f 75 70 20 22 20 6a 6f 62 67 xjobgroup " jobg
1f80: 72 6f 75 70 29 20 36 30 29 0a 09 09 09 09 20 20 roup) 60).....
1f90: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1fa0: 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 1 "WARNING: num
1fb0: 62 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 ber of jobs " nu
1fc0: 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 m-running-in-job
1fd0: 67 72 6f 75 70 20 0a 09 09 09 09 09 09 20 20 20 group .......
1fe0: 22 20 69 6e 20 6a 6f 62 67 72 6f 75 70 20 5c 22 " in jobgroup \"
1ff0: 22 20 6a 6f 62 67 72 6f 75 70 20 22 5c 22 20 65 " jobgroup "\" e
2000: 78 63 65 65 64 73 20 6c 69 6d 69 74 20 6f 66 20 xceeds limit of
2010: 22 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 " job-group-limi
2020: 74 29 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 t))..... #t)...
2030: 09 09 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a .. (else #f)))).
2040: 09 20 20 28 6c 69 73 74 20 28 6e 6f 74 20 63 61 . (list (not ca
2050: 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 29 20 n-not-run-more)
2060: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d num-running num-
2070: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
2080: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
2090: 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 nt-jobs job-grou
20a0: 70 2d 6c 69 6d 69 74 29 29 29 29 29 0a 0a 3b 3b p-limit)))))..;;
20b0: 20 20 74 65 73 74 2d 6e 61 6d 65 73 3a 20 43 6f test-names: Co
20c0: 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 70 61 mma separated pa
20d0: 74 74 65 72 6e 73 20 73 61 6d 65 20 61 73 20 74 tterns same as t
20e0: 65 73 74 2d 70 61 74 74 73 20 62 75 74 20 75 73 est-patts but us
20f0: 65 64 20 69 6e 20 73 65 6c 65 63 74 69 6f 6e 20 ed in selection
2100: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
2110: 20 6f 66 20 74 65 73 74 73 20 74 6f 20 72 75 6e of tests to run
2120: 2e 20 54 68 65 20 69 74 65 6d 20 70 6f 72 74 69 . The item porti
2130: 6f 6e 73 20 61 72 65 20 6e 6f 74 20 72 65 73 70 ons are not resp
2140: 65 63 74 65 64 2e 0a 3b 3b 20 20 20 20 20 20 20 ected..;;
2150: 20 20 20 20 20 20 20 46 49 58 4d 45 3a 20 65 72 FIXME: er
2160: 72 6f 72 20 6f 75 74 20 69 66 20 2f 70 61 74 74 ror out if /patt
2170: 20 73 70 65 63 69 66 69 65 64 0a 3b 3b 20 20 20 specified.;;
2180: 20 20 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e .(defin
2190: 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 e (runs:run-test
21a0: 73 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 s target runname
21b0: 20 74 65 73 74 2d 70 61 74 74 73 20 75 73 65 72 test-patts user
21c0: 20 66 6c 61 67 73 29 20 3b 3b 20 74 65 73 74 2d flags) ;; test-
21d0: 6e 61 6d 65 73 0a 20 20 28 63 6f 6d 6d 6f 6e 3a names. (common:
21e0: 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 3b 3b clear-caches) ;;
21f0: 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 68 65 clear all cache
2200: 73 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 s. (let* ((keys
2210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2220: 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d keys:config-get-
2230: 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 fields *configda
2240: 74 2a 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 20 t*)).. (keyvals
2250: 20 20 20 20 20 20 20 20 20 20 20 28 6b 65 79 73 (keys
2260: 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
2270: 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 keys target))..
2280: 28 72 75 6e 2d 69 64 20 20 20 20 20 20 20 20 20 (run-id
2290: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
22a0: 72 75 6e 20 64 62 3a 72 65 67 69 73 74 65 72 2d run db:register-
22b0: 72 75 6e 20 23 66 20 6b 65 79 76 61 6c 73 20 72 run #f keyvals r
22c0: 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f unname "new" "n/
22d0: 61 22 20 75 73 65 72 29 29 20 20 3b 3b 20 20 74 a" user)) ;; t
22e0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 28 64 est-name))).. (d
22f0: 65 66 65 72 72 65 64 20 20 20 20 20 20 20 20 20 eferred
2300: 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 '()) ;; delay r
2310: 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e unning these sin
2320: 63 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 ce they have a w
2330: 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 28 aiton clause.. (
2340: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 20 20 20 runconfigf
2350: 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 (conc *toppa
2360: 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 th* "/runconfigs
2370: 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 72 65 .config")).. (re
2380: 71 75 69 72 65 64 2d 74 65 73 74 73 20 20 20 20 quired-tests
2390: 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 63 '()).. (test-rec
23a0: 6f 72 64 73 20 20 20 20 20 20 20 28 6d 61 6b 65 ords (make
23b0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 -hash-table))..
23c0: 28 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 (all-tests-regis
23d0: 74 72 79 20 28 74 65 73 74 73 3a 67 65 74 2d 61 try (tests:get-a
23e0: 6c 6c 29 29 20 3b 3b 20 28 74 65 73 74 73 3a 67 ll)) ;; (tests:g
23f0: 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 28 et-valid-tests (
2400: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2410: 20 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 74 test-search-pat
2420: 68 29 29 20 3b 3b 20 61 6c 6c 20 76 61 6c 69 64 h)) ;; all valid
2430: 20 74 65 73 74 73 20 74 6f 20 63 68 65 63 6b 20 tests to check
2440: 77 61 69 74 6f 6e 20 6e 61 6d 65 73 0a 09 20 28 waiton names.. (
2450: 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 20 20 all-test-names
2460: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b (hash-table-k
2470: 65 79 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 eys all-tests-re
2480: 67 69 73 74 72 79 29 29 0a 09 20 28 74 65 73 74 gistry)).. (test
2490: 2d 6e 61 6d 65 73 20 20 20 20 20 20 20 20 20 28 -names (
24a0: 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 tests:filter-tes
24b0: 74 2d 6e 61 6d 65 73 20 61 6c 6c 2d 74 65 73 74 t-names all-test
24c0: 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 -names test-patt
24d0: 73 29 29 29 0a 0a 20 20 20 20 3b 3b 20 55 70 64 s))).. ;; Upd
24e0: 61 74 65 20 74 68 65 20 73 79 6e 63 68 72 6f 6e ate the synchron
24f0: 6f 75 73 20 73 65 74 74 69 6e 67 20 69 6e 20 74 ous setting in t
2500: 68 65 20 64 62 20 62 61 73 65 64 20 6f 6e 20 74 he db based on t
2510: 68 65 20 64 65 66 61 75 6c 74 20 6f 72 20 77 68 he default or wh
2520: 61 74 20 69 73 20 73 65 74 20 62 79 20 74 68 65 at is set by the
2530: 20 75 73 65 72 0a 20 20 20 20 3b 3b 20 54 68 69 user. ;; Thi
2540: 73 20 69 73 20 64 6f 6e 65 20 6f 6e 63 65 20 68 s is done once h
2550: 65 72 65 20 6f 6e 20 61 20 63 61 6c 6c 20 74 6f ere on a call to
2560: 20 72 75 6e 20 74 65 73 74 73 20 72 61 74 68 65 run tests rathe
2570: 72 20 74 68 61 6e 20 6f 6e 20 65 76 65 72 79 20 r than on every
2580: 63 61 6c 6c 20 74 6f 20 6f 70 65 6e 2d 64 62 0a call to open-db.
2590: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
25a0: 72 75 6e 20 64 62 3a 73 65 74 2d 73 79 6e 63 20 run db:set-sync
25b0: 23 66 29 0a 0a 20 20 20 20 28 73 65 74 2d 6d 65 #f).. (set-me
25c0: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
25d0: 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a 20 6b run-id inkeys: k
25e0: 65 79 73 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 eys inrunname: r
25f0: 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 unname) ;; these
2600: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
2610: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
2620: 70 72 6f 63 65 73 73 0a 20 20 20 20 28 69 66 20 process. (if
2630: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 (file-exists? ru
2640: 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 nconfigf)..(setu
2650: 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 72 p-env-defaults r
2660: 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 unconfigf run-id
2670: 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 *already-seen-r
2680: 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 6b unconfig-info* k
2690: 65 79 76 61 6c 73 20 22 70 72 65 2d 6c 61 75 6e eyvals "pre-laun
26a0: 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 0a 09 28 ch-env-vars")..(
26b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
26c0: 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e ARNING: You do n
26d0: 6f 74 20 68 61 76 65 20 61 20 72 75 6e 20 63 6f ot have a run co
26e0: 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 72 75 6e nfig file: " run
26f0: 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 20 0a 20 configf)). .
2700: 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c ;; look up al
2710: 6c 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e 67 l tests matching
2720: 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 61 72 the comma separ
2730: 61 74 65 64 20 6c 69 73 74 20 6f 66 20 67 6c 6f ated list of glo
2740: 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 65 73 bs in. ;; tes
2750: 74 2d 70 61 74 74 73 20 28 75 73 69 6e 67 20 25 t-patts (using %
2760: 20 61 73 20 77 69 6c 64 63 61 72 64 29 0a 0a 20 as wildcard)..
2770: 20 20 20 3b 3b 20 28 73 65 74 21 20 74 65 73 74 ;; (set! test
2780: 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 2d 64 -names (delete-d
2790: 75 70 6c 69 63 61 74 65 73 20 28 74 65 73 74 73 uplicates (tests
27a0: 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 :get-valid-tests
27b0: 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 73 74 2d *toppath* test-
27c0: 70 61 74 74 73 29 29 29 0a 20 20 20 20 28 64 65 patts))). (de
27d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
27e0: 20 22 74 65 73 74 20 6e 61 6d 65 73 20 22 20 74 "test names " t
27f0: 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 20 20 est-names)..
2800: 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 ;; on the first
2810: 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 pass or call to
2820: 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 46 41 run-tests set FA
2830: 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 ILS to NOT_START
2840: 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 ED if. ;; -ke
2850: 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 63 69 epgoing is speci
2860: 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 65 71 fied. (if (eq
2870: 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 ? *passnum* 0)..
2880: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 (begin.. ;; hav
2890: 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 e to delete test
28a0: 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e records where N
28b0: 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 OT_STARTED since
28c0: 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 they can cause
28d0: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 -keepgoing to ..
28e0: 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 ;; get stuck d
28f0: 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 ue to becoming i
2900: 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d naccessible from
2910: 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 a failed test.
2920: 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 I.e. if test B d
2930: 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e epends .. ;; on
2940: 20 74 65 73 74 20 41 20 62 75 74 20 74 65 73 74 test A but test
2950: 20 42 20 72 65 61 63 68 65 64 20 74 68 65 20 70 B reached the p
2960: 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 oint on being re
2970: 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f gistered as NOT_
2980: 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 STARTED and test
2990: 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 .. ;; A failed
29a0: 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 for some reason
29b0: 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 then on re-run u
29c0: 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 sing -keepgoing
29d0: 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 the run can neve
29e0: 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 r complete... (
29f0: 63 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 cdb:delete-tests
2a00: 2d 69 6e 2d 73 74 61 74 65 20 2a 72 75 6e 72 65 -in-state *runre
2a10: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 22 4e 4f mote* run-id "NO
2a20: 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 20 28 T_STARTED").. (
2a30: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
2a40: 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 b:set-tests-stat
2a50: 65 2d 73 74 61 74 75 73 20 23 66 20 72 75 6e 2d e-status #f run-
2a60: 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 23 66 id test-names #f
2a70: 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 54 41 "FAIL" "NOT_STA
2a80: 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 29 0a RTED" "FAIL"))).
2a90: 0a 20 20 20 20 3b 3b 20 45 6e 73 75 72 65 20 61 . ;; Ensure a
2aa0: 6c 6c 20 74 65 73 74 73 20 61 72 65 20 72 65 67 ll tests are reg
2ab0: 69 73 74 65 72 65 64 20 69 6e 20 74 68 65 20 74 istered in the t
2ac0: 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 0a 20 est_meta table.
2ad0: 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d (runs:update-
2ae0: 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 23 66 all-test_meta #f
2af0: 29 0a 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 ).. ;; now ad
2b00: 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 d non-directly r
2b10: 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 eferenced depend
2b20: 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 encies (i.e. wai
2b30: 74 6f 6e 29 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d ton). ;;=====
2b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b80: 3d 0a 20 20 20 20 3b 3b 20 72 65 66 61 63 74 6f =. ;; refacto
2b90: 72 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 ring this block
2ba0: 69 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 into tests:get-f
2bb0: 75 6c 6c 2d 64 61 74 61 0a 20 20 20 20 3b 3b 0a ull-data. ;;.
2bc0: 20 20 20 20 3b 3b 20 57 68 61 74 20 68 61 70 70 ;; What happ
2bd0: 65 6e 64 65 64 2c 20 74 68 69 73 20 63 6f 64 65 ended, this code
2be0: 20 69 73 20 6e 6f 77 20 64 75 70 6c 69 63 61 74 is now duplicat
2bf0: 65 64 20 69 6e 20 74 65 73 74 73 21 3f 0a 20 20 ed in tests!?.
2c00: 20 20 3b 3b 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d ;;. ;;=====
2c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c50: 3d 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 =. (if (not (
2c60: 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 null? test-names
2c70: 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ))..(let loop ((
2c80: 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 hed (car test-na
2c90: 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 mes))... (tal
2ca0: 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 (cdr test-names)
2cb0: 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 )) ;; 'r
2cc0: 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c eturn-procs tell
2cd0: 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 s the config rea
2ce0: 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e der to prep runn
2cf0: 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 ing system but r
2d00: 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 eturn a proc..
2d10: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
2d20: 79 20 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b 20 y *toppath*) ;;
2d30: 50 4c 45 41 53 45 20 4f 50 54 49 4d 49 5a 45 20 PLEASE OPTIMIZE
2d40: 4d 45 21 21 21 20 49 20 74 68 69 6e 6b 20 74 68 ME!!! I think th
2d50: 69 73 20 73 68 6f 75 6c 64 20 62 65 20 61 20 6e is should be a n
2d60: 6f 2d 6f 70 20 62 75 74 20 74 68 65 72 65 20 61 o-op but there a
2d70: 72 65 20 73 65 76 65 72 61 6c 20 70 6c 61 63 65 re several place
2d80: 73 20 77 68 65 72 65 20 63 68 61 6e 67 65 2d 64 s where change-d
2d90: 69 72 65 63 74 6f 72 69 65 73 20 63 6f 75 6c 64 irectories could
2da0: 20 62 65 20 68 61 70 70 65 6e 69 6e 67 2e 0a 09 be happening...
2db0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE
2dc0: 53 54 5f 4e 41 4d 45 22 20 68 65 64 29 20 3b 3b ST_NAME" hed) ;;
2dd0: 20 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e .. (let* ((con
2de0: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
2df0: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 61 testconfig hed a
2e00: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
2e10: 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 y 'return-procs)
2e20: 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 6c )... (waitons (l
2e30: 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 et ((instr (if c
2e40: 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 20 20 28 onfig ...... (
2e50: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f config-lookup co
2e60: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
2e70: 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 ts" "waiton")...
2e80: 09 09 09 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 ... (begin ;;
2e90: 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 No config means
2ea0: 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 this is a non-ex
2eb0: 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 09 istant test.....
2ec0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
2ed0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f 6e nt 0 "ERROR: non
2ee0: 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 -existent requir
2ef0: 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 20 ed test \"" hed
2f00: 22 5c 22 22 29 0a 09 09 09 09 09 20 20 20 20 20 "\"")......
2f10: 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 09 09 (exit 1)))))....
2f20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2f30: 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 -info 8 "waitons
2f40: 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 string is " ins
2f50: 74 72 29 0a 09 09 09 20 20 20 20 28 6c 65 74 20 tr).... (let
2f60: 28 28 6e 65 77 77 61 69 74 6f 6e 73 0a 09 09 09 ((newwaitons....
2f70: 09 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 . (string-spli
2f80: 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 20 20 t (cond.......
2f90: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 ((procedure? ins
2fa0: 74 72 29 0a 09 09 09 09 09 09 20 20 20 28 6c 65 tr)....... (le
2fb0: 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 t ((res (instr))
2fc0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 )....... (de
2fd0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
2fe0: 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 "waiton procedu
2ff0: 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 re results in st
3000: 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 ring " res " for
3010: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
3020: 09 09 09 20 20 20 20 20 72 65 73 29 29 0a 09 09 ... res))...
3030: 09 09 09 09 20 20 28 28 73 74 72 69 6e 67 3f 20 .... ((string?
3040: 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 instr) instr
3050: 29 0a 09 09 09 09 09 09 20 20 28 65 6c 73 65 20 )....... (else
3060: 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 4e 4f 54 ....... ;; NOT
3070: 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 E: This is actua
3080: 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 lly the case of
3090: 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b *no* waitons! ;;
30a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
30b0: 22 45 52 52 4f 52 3a 20 73 6f 6d 65 74 68 69 6e "ERROR: somethin
30c0: 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 g went wrong in
30d0: 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f processing waito
30e0: 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 ns for test " he
30f0: 64 29 0a 09 09 09 09 09 09 20 20 20 22 22 29 29 d)....... ""))
3100: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 66 69 ))).... (fi
3110: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
3120: 0a 09 09 09 09 09 28 69 66 20 28 68 61 73 68 2d ......(if (hash-
3130: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
3140: 74 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 t all-tests-regi
3150: 73 74 72 79 20 78 20 23 66 29 0a 09 09 09 09 09 stry x #f)......
3160: 20 20 20 20 23 74 0a 09 09 09 09 09 20 20 20 20 #t......
3170: 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 (begin......
3180: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3190: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 "ERROR: test "
31a0: 68 65 64 20 22 20 68 61 73 20 75 6e 72 65 63 6f hed " has unreco
31b0: 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 gnised waiton te
31c0: 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 09 stname " x).....
31d0: 09 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 09 . #f)))....
31e0: 09 20 20 20 20 20 20 6e 65 77 77 61 69 74 6f 6e . newwaiton
31f0: 73 29 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 s))))).. (deb
3200: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
3210: 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 "waitons: " wait
3220: 6f 6e 73 29 0a 09 20 20 20 20 3b 3b 20 63 68 65 ons).. ;; che
3230: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
3240: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
3250: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
3260: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
3270: 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 ssue an.. ;;
3280: 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 error.. (if (
3290: 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f member hed waito
32a0: 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 ns)...(begin...
32b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
32c0: 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 "ERROR: test " h
32d0: 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 ed " has listed
32e0: 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 itself as a wait
32f0: 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 on, please corre
3300: 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 28 ct this!")... (
3310: 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 set! waitons (fi
3320: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
3330: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 (not (equal? x h
3340: 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 ed))) waitons)))
3350: 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 ).. .. ;;
3360: 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d 73 3a (items (items:
3370: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
3380: 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 29 0a onfig config))).
3390: 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 . (if (not (h
33a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
33b0: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 fault test-recor
33c0: 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 28 68 ds hed #f))...(h
33d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
33e0: 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 est-records.....
33f0: 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 hed (vector hed
3400: 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 20 ;; 0......
3410: 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 config ;; 1
3420: 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 74 6f ...... waito
3430: 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 20 ns ;; 2......
3440: 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 (config-lookup
3450: 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
3460: 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 ments" "priority
3470: 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 ") ;; priori
3480: 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 20 28 ty 3...... (
3490: 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 let ((items
34a0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
34b0: 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 /default config
34c0: 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 "items" #f)) ;;
34d0: 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 items 4.......
34e0: 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 (itemstable (ha
34f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3500: 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 ault config "ite
3510: 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a mstable" #f))) .
3520: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 ..... ;; i
3530: 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f f either items o
3540: 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 r items table is
3550: 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 a proc return i
3560: 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e t so test runnin
3570: 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b g...... ;;
3580: 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f process can kno
3590: 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a w to call items:
35a0: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
35b0: 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 20 20 onfig......
35c0: 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 ;; if either i
35d0: 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e s a list and non
35e0: 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 e is a proc go a
35f0: 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 head and call ge
3600: 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 20 20 t-items......
3610: 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 ;; otherwise
3620: 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 return #f - thi
3630: 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 s is not an iter
3640: 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 20 ated test......
3650: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 (cond.....
3660: 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 ..((procedure? i
3670: 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 tems) .....
3680: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
3690: 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 69 73 info 4 "items is
36a0: 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 a procedure, wi
36b0: 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a ll calc later").
36c0: 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 20 20 ...... items)
36d0: 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 ;; calc
36e0: 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 70 later.......((p
36f0: 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 rocedure? itemst
3700: 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 64 65 able)....... (de
3710: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
3720: 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 "itemstable is
3730: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
3740: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
3750: 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 6c 65 ..... itemstable
3760: 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ) ;; calc
3770: 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 66 69 later.......((fi
3780: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
3790: 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 ........ (let
37a0: 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a ((val (car x))).
37b0: 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 ....... (if
37c0: 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 (procedure? val)
37d0: 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 val #f)))......
37e0: 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 .. (append (if (
37f0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
3800: 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 ms '()).........
3810: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
3820: 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 stable) itemstab
3830: 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 le '()))).......
3840: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
3850: 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 6c 69 ).......((or (li
3860: 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f st? items)(list?
3870: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b itemstable)) ;;
3880: 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 calc now.......
3890: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
38a0: 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e 64 20 fo 4 "items and
38b0: 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c itemstable are l
38c0: 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e ists, calc now\n
38d0: 22 0a 09 09 09 09 09 09 09 09 20 20 20 22 20 20 "......... "
38e0: 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 items: " items
38f0: 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 " itemstable: "
3900: 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 itemstable)....
3910: 09 09 09 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 ... (items:get-i
3920: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
3930: 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 config)).......
3940: 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 (else #f)))
3950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3960: 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 ;; not ite
3970: 72 61 74 65 64 0a 09 09 09 09 09 20 20 20 20 20 rated......
3980: 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 #f ;; items
3990: 64 61 74 20 35 0a 09 09 09 09 09 20 20 20 20 20 dat 5......
39a0: 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 #f ;; spare
39b0: 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d - used for item
39c0: 2d 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 20 -path......
39d0: 29 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 ))).. (for-ea
39e0: 63 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 ch .. (lambd
39f0: 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 a (waiton)..
3a00: 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 (if (and wait
3a10: 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 on (not (member
3a20: 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 waiton test-name
3a30: 73 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e s)))... (begin
3a40: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 ... (set! re
3a50: 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f quired-tests (co
3a60: 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 ns waiton requir
3a70: 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 ed-tests))...
3a80: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
3a90: 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 es (cons waiton
3aa0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 test-names)))))
3ab0: 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 ;; was an append
3ac0: 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 , now a cons..
3ad0: 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 waitons)..
3ae0: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
3af0: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
3b00: 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 tes (append wait
3b10: 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 20 ons tal))))..
3b20: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
3b30: 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 l? remtests))...
3b40: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d (loop (car rem
3b50: 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 tests)(cdr remte
3b60: 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 20 sts)))))))..
3b70: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
3b80: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
3b90: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
3ba0: 6e 66 6f 20 31 20 22 41 64 64 69 6e 67 20 22 20 nfo 1 "Adding "
3bb0: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 required-tests "
3bc0: 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 to the run queu
3bd0: 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 e")). ;; NOTE
3be0: 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 : these are all
3bf0: 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 parent tests, it
3c00: 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 ems are not expa
3c10: 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 nded yet.. (d
3c20: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3c30: 34 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3d 4 "test-records=
3c40: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
3c50: 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 list test-record
3c60: 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 72 s)). (let ((r
3c70: 65 67 6c 65 6e 20 28 63 6f 6e 66 69 67 66 3a 6c eglen (configf:l
3c80: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
3c90: 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e 71 75 * "setup" "runqu
3ca0: 65 75 65 22 29 29 29 0a 20 20 20 20 20 20 28 69 eue"))). (i
3cb0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 68 61 f (> (length (ha
3cc0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 sh-table-keys te
3cd0: 73 74 2d 72 65 63 6f 72 64 73 29 29 20 30 29 0a st-records)) 0).
3ce0: 09 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 . (runs:run-tes
3cf0: 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 ts-queue run-id
3d00: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 runname test-rec
3d10: 6f 72 64 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 ords keyvals fla
3d20: 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 gs test-patts re
3d30: 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 61 6e quired-tests (an
3d40: 79 2d 3e 6e 75 6d 62 65 72 20 72 65 67 6c 65 6e y->number reglen
3d50: 29 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 ) all-tests-regi
3d60: 73 74 72 79 29 0a 09 20 20 28 64 65 62 75 67 3a stry).. (debug:
3d70: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4e 6f print-info 0 "No
3d80: 20 74 65 73 74 73 20 74 6f 20 72 75 6e 22 29 29 tests to run"))
3d90: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
3da0: 6e 74 2d 69 6e 66 6f 20 34 20 22 41 6c 6c 20 64 nt-info 4 "All d
3db0: 6f 6e 65 20 62 79 20 68 65 72 65 22 29 29 29 0a one by here"))).
3dc0: 0a 0a 3b 3b 20 6c 6f 6f 70 20 6c 6f 67 69 63 2e ..;; loop logic.
3dd0: 20 54 68 65 73 65 20 61 72 65 20 75 73 65 64 20 These are used
3de0: 69 6e 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 in runs:run-test
3df0: 73 2d 71 75 65 75 65 20 74 6f 20 6d 61 6b 65 20 s-queue to make
3e00: 69 74 20 61 20 62 69 74 20 6d 6f 72 65 20 72 65 it a bit more re
3e10: 61 64 61 62 6c 65 2e 0a 3b 3b 0a 3b 3b 20 49 66 adable..;;.;; If
3e20: 20 72 65 67 20 6e 6f 74 20 66 75 6c 6c 20 61 6e reg not full an
3e30: 64 20 68 61 76 65 20 69 74 65 6d 73 20 69 6e 20 d have items in
3e40: 74 61 6c 20 74 68 65 6e 20 6c 6f 6f 70 20 77 69 tal then loop wi
3e50: 74 68 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 th (car tal)(cdr
3e60: 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 tal) reg reruns
3e70: 0a 3b 3b 20 49 66 20 72 65 67 20 69 73 20 66 75 .;; If reg is fu
3e80: 6c 6c 20 28 69 2e 65 2e 20 6c 65 6e 67 74 68 20 ll (i.e. length
3e90: 3e 3d 20 6e 0a 3b 3b 20 20 20 6c 6f 6f 70 20 77 >= n.;; loop w
3ea0: 69 74 68 20 28 63 61 72 20 72 65 67 29 20 74 61 ith (car reg) ta
3eb0: 6c 20 28 63 64 72 20 72 65 67 29 20 72 65 72 75 l (cdr reg) reru
3ec0: 6e 73 0a 3b 3b 20 49 66 20 74 61 6c 20 69 73 20 ns.;; If tal is
3ed0: 65 6d 70 74 79 0a 3b 3b 20 20 20 62 75 74 20 68 empty.;; but h
3ee0: 61 76 65 20 69 74 65 6d 73 20 69 6e 20 72 65 67 ave items in reg
3ef0: 3b 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 72 ; loop with (car
3f00: 20 72 65 67 29 28 63 64 72 20 72 65 67 29 20 27 reg)(cdr reg) '
3f10: 28 29 20 72 65 72 75 6e 73 0a 3b 3b 20 20 20 49 () reruns.;; I
3f20: 66 20 72 65 67 20 69 73 20 65 6d 70 74 79 20 3d f reg is empty =
3f30: 3e 20 61 6c 6c 20 64 6f 6e 65 0a 0a 28 64 65 66 > all done..(def
3f40: 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ine (runs:queue-
3f50: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg
3f60: 20 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 28 69 n regfull). (i
3f70: 66 20 72 65 67 66 75 6c 6c 0a 20 20 20 20 20 20 f regfull.
3f80: 28 63 61 72 20 72 65 67 29 0a 20 20 20 20 20 20 (car reg).
3f90: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 (if (null? tal)
3fa0: 3b 3b 20 74 61 6c 20 69 73 20 75 73 65 64 20 75 ;; tal is used u
3fb0: 70 2c 20 70 6f 70 20 66 72 6f 6d 20 72 65 67 0a p, pop from reg.
3fc0: 09 20 20 28 63 61 72 20 72 65 67 29 0a 09 20 20 . (car reg)..
3fd0: 28 63 61 72 20 74 61 6c 29 29 29 29 0a 0a 3b 3b (car tal))))..;;
3fe0: 20 20 20 28 63 6f 6e 64 0a 3b 3b 20 20 20 20 28 (cond.;; (
3ff0: 28 61 6e 64 20 72 65 67 66 75 6c 6c 20 28 6e 75 (and regfull (nu
4000: 6c 6c 3f 20 72 65 67 29 28 6e 6f 74 20 28 6e 75 ll? reg)(not (nu
4010: 6c 6c 3f 20 74 61 6c 29 29 29 20 20 20 20 20 20 ll? tal)))
4020: 28 63 61 72 20 74 61 6c 29 29 0a 3b 3b 20 20 20 (car tal)).;;
4030: 20 28 28 61 6e 64 20 72 65 67 66 75 6c 6c 20 28 ((and regfull (
4040: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 not (null? reg))
4050: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4060: 20 20 28 63 61 72 20 72 65 67 29 29 0a 3b 3b 20 (car reg)).;;
4070: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 65 ((and (not re
4080: 67 66 75 6c 6c 29 28 6e 75 6c 6c 3f 20 74 61 6c gfull)(null? tal
4090: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 )(not (null? reg
40a0: 29 29 29 20 28 63 61 72 20 72 65 67 29 29 0a 3b ))) (car reg)).;
40b0: 3b 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 ; ((and (not
40c0: 72 65 67 66 75 6c 6c 29 28 6e 6f 74 20 28 6e 75 regfull)(not (nu
40d0: 6c 6c 3f 20 74 61 6c 29 29 29 20 20 20 20 20 20 ll? tal)))
40e0: 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 29 (car tal))
40f0: 0a 3b 3b 20 20 20 20 28 65 6c 73 65 0a 3b 3b 20 .;; (else.;;
4100: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4110: 20 30 20 22 45 52 52 4f 52 3a 20 72 75 6e 73 3a 0 "ERROR: runs:
4120: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 2c 20 queue-next-hed,
4130: 74 61 6c 3d 22 20 74 61 6c 20 22 2c 20 72 65 67 tal=" tal ", reg
4140: 3d 22 20 72 65 67 20 22 2c 20 6e 3d 22 20 6e 20 =" reg ", n=" n
4150: 22 2c 20 72 65 67 66 75 6c 6c 3d 22 20 72 65 67 ", regfull=" reg
4160: 66 75 6c 6c 29 0a 3b 3b 20 20 20 20 20 23 66 29 full).;; #f)
4170: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
4180: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
4190: 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 tal reg n regfu
41a0: 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c ll). (if regful
41b0: 6c 0a 20 20 20 20 20 20 74 61 6c 0a 20 20 20 20 l. tal.
41c0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
41d0: 29 20 3b 3b 20 6d 75 73 74 20 74 72 61 6e 73 66 ) ;; must transf
41e0: 65 72 20 66 72 6f 6d 20 72 65 67 0a 09 20 20 28 er from reg.. (
41f0: 63 64 72 20 72 65 67 29 0a 09 20 20 28 63 64 72 cdr reg).. (cdr
4200: 20 74 61 6c 29 29 29 29 0a 0a 28 64 65 66 69 6e tal))))..(defin
4210: 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 e (runs:queue-ne
4220: 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 6e xt-reg tal reg n
4230: 20 72 65 67 66 75 6c 6c 29 0a 20 20 28 69 66 20 regfull). (if
4240: 72 65 67 66 75 6c 6c 0a 20 20 20 20 20 20 28 63 regfull. (c
4250: 64 72 20 72 65 67 29 0a 20 20 20 20 20 20 28 69 dr reg). (i
4260: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b f (null? tal) ;;
4270: 20 69 66 20 74 61 6c 20 69 73 20 6e 75 6c 6c 20 if tal is null
4280: 61 6e 64 20 72 65 67 20 6e 6f 74 20 66 75 6c 6c and reg not full
4290: 20 74 68 65 6e 20 27 28 29 20 61 73 20 72 65 67 then '() as reg
42a0: 20 63 6f 6e 74 65 6e 74 73 20 6d 6f 76 65 64 20 contents moved
42b0: 74 6f 20 74 61 6c 0a 09 20 20 27 28 29 0a 09 20 to tal.. '()..
42c0: 20 72 65 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 reg)))..(define
42d0: 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 runs:nothing-le
42e0: 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e ft-in-queue-coun
42f0: 74 20 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 t 0)..(define (r
4300: 75 6e 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d 73 uns:expand-items
4310: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
4320: 75 6e 73 20 72 65 67 66 75 6c 6c 20 6e 65 77 74 uns regfull newt
4330: 61 6c 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d al jobgroup max-
4340: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
4350: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 run-id waitons i
4360: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f 64 tem-path testmod
4370: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 63 61 e test-record ca
4380: 6e 2d 72 75 6e 2d 6d 6f 72 65 20 69 74 65 6d 73 n-run-more items
4390: 20 72 75 6e 6e 61 6d 65 20 74 63 6f 6e 66 69 67 runname tconfig
43a0: 20 72 65 67 6c 65 6e 20 74 65 73 74 2d 72 65 67 reglen test-reg
43b0: 69 73 74 72 79 20 74 65 73 74 2d 72 65 63 6f 72 istry test-recor
43c0: 64 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f ds). (let* ((lo
43d0: 6f 70 2d 6c 69 73 74 20 20 20 20 20 20 20 28 6c op-list (l
43e0: 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 ist hed tal reg
43f0: 72 65 72 75 6e 73 29 29 0a 09 20 28 70 72 65 72 reruns)).. (prer
4400: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 6d 74 3a eqs-not-met (mt:
4410: 6c 61 7a 79 2d 67 65 74 2d 70 72 65 72 65 71 73 lazy-get-prereqs
4420: 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 -not-met run-id
4430: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
4440: 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 h mode: testmode
4450: 29 29 0a 09 20 28 66 61 69 6c 73 20 20 20 20 20 )).. (fails
4460: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
4470: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
4480: 6f 74 2d 6d 65 74 29 29 0a 09 20 28 6e 6f 6e 2d ot-met)).. (non-
4490: 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 72 75 6e completed (run
44a0: 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c s:calc-not-compl
44b0: 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 eted prereqs-not
44c0: 2d 6d 65 74 29 29 29 0a 20 20 20 20 28 64 65 62 -met))). (deb
44d0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
44e0: 22 53 54 41 52 54 20 4f 46 20 49 4e 4e 45 52 20 "START OF INNER
44f0: 43 4f 4e 44 20 23 32 20 22 0a 09 09 20 20 20 20 COND #2 "...
4500: 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d 6f "\n can-run-mo
4510: 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 75 6e re: " can-run
4520: 2d 6d 6f 72 65 0a 09 09 20 20 20 20 20 20 22 5c -more... "\
4530: 6e 20 74 65 73 74 6e 61 6d 65 3a 20 20 20 20 20 n testname:
4540: 20 20 20 22 20 68 65 64 0a 09 09 20 20 20 20 20 " hed...
4550: 20 22 5c 6e 20 70 72 65 72 65 71 73 2d 6e 6f 74 "\n prereqs-not
4560: 2d 6d 65 74 3a 20 22 20 28 72 75 6e 73 3a 70 72 -met: " (runs:pr
4570: 65 74 74 79 2d 73 74 72 69 6e 67 20 70 72 65 72 etty-string prer
4580: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 20 eqs-not-met)...
4590: 20 20 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d "\n non-com
45a0: 70 6c 65 74 65 64 3a 20 20 20 22 20 28 72 75 6e pleted: " (run
45b0: 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 s:pretty-string
45c0: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 20 0a non-completed) .
45d0: 09 09 20 20 20 20 20 20 22 5c 6e 20 66 61 69 6c .. "\n fail
45e0: 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 28 s: " (
45f0: 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 runs:pretty-stri
4600: 6e 67 20 66 61 69 6c 73 29 0a 09 09 20 20 20 20 ng fails)...
4610: 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 3a 20 "\n testmode:
4620: 20 20 20 20 20 20 20 22 20 74 65 73 74 6d 6f 64 " testmod
4630: 65 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 28 6d e... "\n (m
4640: 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 ember 'toplevel
4650: 74 65 73 74 6d 6f 64 65 29 3a 20 22 20 28 6d 65 testmode): " (me
4660: 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 mber 'toplevel t
4670: 65 73 74 6d 6f 64 65 29 0a 09 09 20 20 20 20 20 estmode)...
4680: 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d "\n (null? non-
4690: 63 6f 6d 70 6c 65 74 65 64 29 3a 20 20 20 20 22 completed): "
46a0: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
46b0: 6c 65 74 65 64 29 0a 09 09 20 20 20 20 20 20 22 leted)... "
46c0: 5c 6e 20 72 65 72 75 6e 73 3a 20 20 20 20 20 20 \n reruns:
46d0: 20 20 20 20 22 20 72 65 72 75 6e 73 0a 09 09 20 " reruns...
46e0: 20 20 20 20 20 22 5c 6e 20 69 74 65 6d 73 3a 20 "\n items:
46f0: 20 20 20 20 20 20 20 20 20 20 22 20 69 74 65 6d " item
4700: 73 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 63 61 s... "\n ca
4710: 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 20 20 22 n-run-more: "
4720: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a 0a can-run-more)..
4730: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 3b (cond. ;
4740: 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 ; all prereqs me
4750: 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 65 20 t, fire off the
4760: 74 65 73 74 0a 20 20 20 20 20 3b 3b 20 6f 72 2c test. ;; or,
4770: 20 69 66 20 69 74 20 69 73 20 61 20 27 74 6f 70 if it is a 'top
4780: 6c 65 76 65 6c 20 74 65 73 74 20 61 6e 64 20 61 level test and a
4790: 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 20 6d ll prereqs not m
47a0: 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 45 44 et are COMPLETED
47b0: 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a 0a 20 20 then launch..
47c0: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6d ((and (not (m
47d0: 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 ember 'toplevel
47e0: 74 65 73 74 6d 6f 64 65 29 29 0a 09 20 20 20 28 testmode)).. (
47f0: 6d 65 6d 62 65 72 20 28 68 61 73 68 2d 74 61 62 member (hash-tab
4800: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
4810: 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 est-registry (ru
4820: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
4830: 74 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 6d 2d t-name hed item-
4840: 70 61 74 68 29 20 27 6e 2f 61 29 0a 09 09 20 20 path) 'n/a)...
4850: 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 6d 6f '(DONOTRUN remo
4860: 76 65 64 20 43 41 4e 4e 4f 54 52 55 4e 29 29 29 ved CANNOTRUN)))
4870: 20 3b 3b 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 ;; *common:cant
4880: 2d 72 75 6e 2d 73 74 61 74 65 73 2d 73 79 6d 2a -run-states-sym*
4890: 29 20 3b 3b 20 27 28 43 4f 4d 50 4c 45 54 45 44 ) ;; '(COMPLETED
48a0: 20 4b 49 4c 4c 45 44 20 57 41 49 56 45 44 20 55 KILLED WAIVED U
48b0: 4e 4b 4e 4f 57 4e 20 49 4e 43 4f 4d 50 4c 45 54 NKNOWN INCOMPLET
48c0: 45 29 29 20 3b 3b 20 74 72 79 20 74 6f 20 63 61 E)) ;; try to ca
48d0: 74 63 68 20 72 65 70 65 61 74 20 70 72 6f 63 65 tch repeat proce
48e0: 73 73 69 6e 67 20 6f 66 20 43 4f 4d 50 4c 45 54 ssing of COMPLET
48f0: 45 44 20 74 65 73 74 73 20 68 65 72 65 0a 20 20 ED tests here.
4900: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4910: 2d 69 6e 66 6f 20 31 20 22 54 65 73 74 20 22 20 -info 1 "Test "
4920: 68 65 64 20 22 20 73 65 74 20 74 6f 20 5c 22 22 hed " set to \""
4930: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4940: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
4950: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
4960: 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 est-name hed ite
4970: 6d 2d 70 61 74 68 29 29 20 22 5c 22 2e 20 52 65 m-path)) "\". Re
4980: 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 moving it from t
4990: 68 65 20 71 75 65 75 65 22 29 0a 20 20 20 20 20 he queue").
49a0: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e (if (or (not (n
49b0: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 ull? tal))..
49c0: 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 (not (null? re
49d0: 67 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 72 g))).. (list (r
49e0: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
49f0: 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 ed tal reg regle
4a00: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 n regfull)...(ru
4a10: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 ns:queue-next-ta
4a20: 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e l tal reg reglen
4a30: 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e regfull)...(run
4a40: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
4a50: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
4a60: 72 65 67 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e regfull)...rerun
4a70: 73 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 s).. (begin..
4a80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4a90: 6e 66 6f 20 30 20 22 4e 6f 74 68 69 6e 67 20 6c nfo 0 "Nothing l
4aa0: 65 66 74 20 69 6e 20 74 68 65 20 71 75 65 75 65 eft in the queue
4ab0: 21 22 29 0a 09 20 20 20 20 3b 3b 20 49 66 20 67 !").. ;; If g
4ac0: 65 74 20 68 65 72 65 20 74 77 69 63 65 20 74 68 et here twice th
4ad0: 65 6e 20 77 65 20 6b 6e 6f 77 20 77 65 27 76 65 en we know we've
4ae0: 20 74 72 69 65 64 20 74 6f 20 65 78 70 61 6e 64 tried to expand
4af0: 20 61 6c 6c 20 69 74 65 6d 73 0a 09 20 20 20 20 all items..
4b00: 3b 3b 20 73 69 6e 63 65 20 74 68 65 72 65 20 6d ;; since there m
4b10: 75 73 74 20 62 65 20 61 20 6c 6f 67 69 63 20 69 ust be a logic i
4b20: 73 73 75 65 20 77 69 74 68 20 74 68 65 20 68 61 ssue with the ha
4b30: 6e 64 6c 69 6e 67 20 6f 66 20 6c 6f 6f 70 73 20 ndling of loops
4b40: 69 6e 20 74 68 65 20 0a 09 20 20 20 20 3b 3b 20 in the .. ;;
4b50: 69 74 65 6d 73 20 65 78 70 61 6e 64 20 70 68 61 items expand pha
4b60: 73 65 20 77 65 20 77 69 6c 6c 20 62 72 75 74 65 se we will brute
4b70: 20 66 6f 72 63 65 20 61 6e 20 65 78 69 74 20 68 force an exit h
4b80: 65 72 65 2e 0a 09 20 20 20 20 28 69 66 20 28 3e ere... (if (>
4b90: 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 runs:nothing-le
4ba0: 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e ft-in-queue-coun
4bb0: 74 20 32 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 t 2)...(begin...
4bc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
4bd0: 20 22 57 41 52 4e 49 4e 47 3a 20 74 68 69 73 20 "WARNING: this
4be0: 63 6f 6e 64 69 74 69 6f 6e 20 69 73 20 74 72 69 condition is tri
4bf0: 67 67 65 72 65 64 20 77 68 65 6e 20 74 68 65 72 ggered when ther
4c00: 65 20 77 65 72 65 20 6e 6f 20 69 74 65 6d 73 20 e were no items
4c10: 74 6f 20 65 78 70 61 6e 64 20 61 6e 64 20 6e 6f to expand and no
4c20: 74 68 69 6e 67 20 74 6f 20 72 75 6e 2e 20 50 6c thing to run. Pl
4c30: 65 61 73 65 20 63 68 65 63 6b 20 79 6f 75 72 20 ease check your
4c40: 72 75 6e 20 66 6f 72 20 63 6f 6d 70 6c 65 74 65 run for complete
4c50: 6e 65 73 73 22 29 0a 09 09 20 20 28 65 78 69 74 ness")... (exit
4c60: 20 30 29 29 0a 09 09 28 73 65 74 21 20 72 75 6e 0))...(set! run
4c70: 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 s:nothing-left-i
4c80: 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 28 2b n-queue-count (+
4c90: 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 runs:nothing-le
4ca0: 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e ft-in-queue-coun
4cb0: 74 20 31 29 29 29 0a 09 20 20 20 20 23 66 29 29 t 1))).. #f))
4cc0: 29 0a 0a 20 20 20 20 20 3b 3b 20 0a 20 20 20 20 ).. ;; .
4cd0: 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 ((or (null? pre
4ce0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 20 reqs-not-met)..
4cf0: 20 28 61 6e 64 20 28 6d 65 6d 62 65 72 20 27 74 (and (member 't
4d00: 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 oplevel testmode
4d10: 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f ).. (null?
4d20: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 non-completed))
4d30: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
4d40: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e rint-info 4 "run
4d50: 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d 73 3a 20 s:expand-items:
4d60: 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 (or (null? prere
4d70: 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 28 61 6e 64 qs-not-met) (and
4d80: 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 (member 'toplev
4d90: 65 6c 20 74 65 73 74 6d 6f 64 65 29 28 6e 75 6c el testmode)(nul
4da0: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
4db0: 29 29 29 22 29 0a 20 20 20 20 20 20 28 6c 65 74 )))"). (let
4dc0: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 ((test-name (te
4dd0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
4de0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
4df0: 72 65 63 6f 72 64 29 29 29 0a 09 28 73 65 74 65 record)))..(sete
4e00: 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 nv "MT_TEST_NAME
4e10: 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 " test-name) ;;
4e20: 0a 09 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 ..(setenv "MT_RU
4e30: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
4e40: 29 0a 09 28 73 65 74 2d 6d 65 67 61 74 65 73 74 )..(set-megatest
4e50: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
4e60: 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e inrunname: runn
4e70: 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 ame) ;; these ma
4e80: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
4e90: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
4ea0: 63 65 73 73 0a 09 28 6c 65 74 20 28 28 69 74 65 cess..(let ((ite
4eb0: 6d 73 2d 6c 69 73 74 20 28 69 74 65 6d 73 3a 67 ms-list (items:g
4ec0: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
4ed0: 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 29 29 0a nfig tconfig))).
4ee0: 09 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 . (if (list? it
4ef0: 65 6d 73 2d 6c 69 73 74 29 0a 09 20 20 20 20 20 ems-list)..
4f00: 20 28 62 65 67 69 6e 0a 09 09 28 74 65 73 74 73 (begin...(tests
4f10: 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 :testqueue-set-i
4f20: 74 65 6d 73 21 20 74 65 73 74 2d 72 65 63 6f 72 tems! test-recor
4f30: 64 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 d items-list)...
4f40: 28 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 (list hed tal re
4f50: 67 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 g reruns))..
4f60: 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 (begin...(debu
4f70: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
4f80: 3a 20 54 68 65 20 70 72 6f 63 20 66 72 6f 6d 20 : The proc from
4f90: 72 65 61 64 69 6e 67 20 74 68 65 20 69 74 65 6d reading the item
4fa0: 73 20 74 61 62 6c 65 20 64 69 64 20 6e 6f 74 20 s table did not
4fb0: 79 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 yield a list - p
4fc0: 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 lease report thi
4fd0: 73 22 29 0a 09 09 28 65 78 69 74 20 31 29 29 29 s")...(exit 1)))
4fe0: 29 29 29 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 ))).. ((and
4ff0: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 20 (null? fails)..
5000: 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 6f (not (null? no
5010: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a 20 n-completed))).
5020: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 6c 6c (let* ((all
5030: 69 6e 71 75 65 75 65 20 28 6d 61 70 20 28 6c 61 inqueue (map (la
5040: 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 74 72 mbda (x)(if (str
5050: 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a 74 65 ing? x) x (db:te
5060: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
5070: 78 29 29 29 0a 20 20 20 20 20 20 20 20 09 09 20 x))). ..
5080: 20 20 20 20 20 28 61 70 70 65 6e 64 20 6e 65 77 (append new
5090: 74 61 6c 20 72 65 72 75 6e 73 29 29 29 0a 09 20 tal reruns)))..
50a0: 20 20 20 20 3b 3b 20 70 72 65 72 65 71 73 74 72 ;; prereqstr
50b0: 73 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 s is a list of t
50c0: 65 73 74 20 6e 61 6d 65 73 20 61 73 20 73 74 72 est names as str
50d0: 69 6e 67 73 20 74 68 61 74 20 61 72 65 20 70 72 ings that are pr
50e0: 65 72 65 71 73 20 66 6f 72 20 68 65 64 0a 20 20 ereqs for hed.
50f0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 65 72 (prer
5100: 65 71 73 74 72 73 20 28 64 65 6c 65 74 65 2d 64 eqstrs (delete-d
5110: 75 70 6c 69 63 61 74 65 73 20 28 6d 61 70 20 28 uplicates (map (
5120: 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 lambda (x)(if (s
5130: 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a tring? x) x (db:
5140: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
5150: 65 20 78 29 29 29 0a 09 09 09 09 09 09 20 70 72 e x)))....... pr
5160: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 ereqs-not-met)))
5170: 0a 09 20 20 20 20 20 3b 3b 20 61 20 70 72 65 72 .. ;; a prer
5180: 65 71 20 74 68 61 74 20 69 73 20 6e 6f 74 20 66 eq that is not f
5190: 6f 75 6e 64 20 69 6e 20 61 6c 6c 69 6e 71 75 65 ound in allinque
51a0: 75 65 20 77 69 6c 6c 20 62 65 20 70 75 74 20 69 ue will be put i
51b0: 6e 20 74 68 65 20 6e 6f 74 69 6e 71 75 65 75 65 n the notinqueue
51c0: 20 6c 69 73 74 0a 09 20 20 20 20 20 3b 3b 20 0a list.. ;; .
51d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
51e0: 28 6e 6f 74 69 6e 71 75 65 75 65 20 28 66 69 6c (notinqueue (fil
51f0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
5200: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
5210: 20 20 20 09 09 20 20 20 28 6e 6f 74 20 28 6d 65 .. (not (me
5220: 6d 62 65 72 20 78 20 61 6c 6c 69 6e 71 75 65 75 mber x allinqueu
5230: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
5240: 20 20 3b 3b 20 20 20 20 09 09 20 70 72 65 72 65 ;; .. prere
5250: 71 73 74 72 73 29 29 0a 09 20 20 20 20 20 28 67 qstrs)).. (g
5260: 69 76 65 2d 75 70 20 20 20 20 23 66 29 29 0a 0a ive-up #f))..
5270: 09 3b 3b 20 57 65 20 63 61 6e 20 67 65 74 20 68 .;; We can get h
5280: 65 72 65 20 77 68 65 6e 20 61 20 70 72 65 72 65 ere when a prere
5290: 71 20 68 61 73 20 6e 6f 74 20 62 65 65 6e 20 72 q has not been r
52a0: 75 6e 20 64 75 65 20 74 6f 20 2a 69 74 2a 20 68 un due to *it* h
52b0: 61 76 69 6e 67 20 61 20 70 72 65 72 65 71 20 74 aving a prereq t
52c0: 68 61 74 20 66 61 69 6c 65 64 2e 0a 09 3b 3b 20 hat failed...;;
52d0: 57 65 20 6e 65 65 64 20 74 6f 20 75 73 65 20 74 We need to use t
52e0: 68 69 73 20 74 6f 20 64 65 71 75 65 75 65 20 74 his to dequeue t
52f0: 68 69 73 20 69 74 65 6d 20 61 73 20 43 41 4e 4e his item as CANN
5300: 4f 54 52 55 4e 0a 09 28 66 6f 72 2d 65 61 63 68 OTRUN..(for-each
5310: 20 28 6c 61 6d 62 64 61 20 28 70 72 65 72 65 71 (lambda (prereq
5320: 29 0a 09 09 20 20 20 20 28 69 66 20 28 65 71 3f )... (if (eq?
5330: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5340: 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 /default test-re
5350: 67 69 73 74 72 79 20 70 72 65 72 65 71 20 27 6a gistry prereq 'j
5360: 75 73 74 66 69 6e 65 29 20 27 43 41 4e 4e 4f 54 ustfine) 'CANNOT
5370: 52 55 4e 29 0a 09 09 09 28 73 65 74 21 20 67 69 RUN)....(set! gi
5380: 76 65 2d 75 70 20 23 74 29 29 29 0a 09 09 20 20 ve-up #t)))...
5390: 70 72 65 72 65 71 73 74 72 73 29 0a 09 28 69 66 prereqstrs)..(if
53a0: 20 28 61 6e 64 20 67 69 76 65 2d 75 70 0a 09 09 (and give-up...
53b0: 20 28 6e 6f 74 20 28 61 6e 64 20 28 6e 75 6c 6c (not (and (null
53c0: 3f 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 ? tal)(null? reg
53d0: 29 29 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 )))).. (let (
53e0: 28 74 72 69 6d 6d 65 64 2d 74 61 6c 20 28 6d 74 (trimmed-tal (mt
53f0: 3a 64 69 73 63 61 72 64 2d 62 6c 6f 63 6b 65 64 :discard-blocked
5400: 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 20 68 65 -tests run-id he
5410: 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 d tal test-recor
5420: 64 73 29 29 0a 09 09 20 20 28 74 72 69 6d 6d 65 ds))... (trimme
5430: 64 2d 72 65 67 20 28 6d 74 3a 64 69 73 63 61 72 d-reg (mt:discar
5440: 64 2d 62 6c 6f 63 6b 65 64 2d 74 65 73 74 73 20 d-blocked-tests
5450: 72 75 6e 2d 69 64 20 68 65 64 20 72 65 67 20 74 run-id hed reg t
5460: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 29 0a 09 est-records)))..
5470: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
5480: 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 74 nt 1 "WARNING: t
5490: 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 est " hed " has
54a0: 64 69 73 63 61 72 64 65 64 20 70 72 65 72 65 71 discarded prereq
54b0: 75 69 73 69 74 65 73 2c 20 72 65 6d 6f 76 69 6e uisites, removin
54c0: 67 20 69 74 20 66 72 6f 6d 20 74 68 65 20 71 75 g it from the qu
54d0: 65 75 65 22 29 0a 0a 09 20 20 20 20 20 20 28 6c eue")... (l
54e0: 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 63 64 et ((test-id (cd
54f0: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
5500: 67 65 74 2d 74 65 73 74 2d 69 64 2d 63 61 63 68 get-test-id-cach
5510: 65 64 20 23 66 20 72 75 6e 2d 69 64 20 68 65 64 ed #f run-id hed
5520: 20 22 22 29 29 29 0a 09 09 28 6d 74 3a 74 65 73 "")))...(mt:tes
5530: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
5540: 75 73 2d 62 79 2d 69 64 20 74 65 73 74 2d 69 64 us-by-id test-id
5550: 20 22 44 45 51 55 45 44 22 20 22 50 52 45 51 5f "DEQUED" "PREQ_
5560: 46 41 49 4c 22 20 22 46 61 69 6c 65 64 20 74 6f FAIL" "Failed to
5570: 20 72 75 6e 20 64 75 65 20 74 6f 20 66 61 69 6c run due to fail
5580: 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 73 ed prerequisites
5590: 22 29 29 0a 09 20 20 20 20 20 20 0a 09 20 20 20 ")).. ..
55a0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c (if (and (nul
55b0: 6c 3f 20 74 72 69 6d 6d 65 64 2d 74 61 6c 29 0a l? trimmed-tal).
55c0: 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 .. (null?
55d0: 74 72 69 6d 6d 65 64 2d 72 65 67 29 29 0a 09 09 trimmed-reg))...
55e0: 20 20 23 66 0a 09 09 20 20 28 6c 69 73 74 20 28 #f... (list (
55f0: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
5600: 68 65 64 20 74 72 69 6d 6d 65 64 2d 74 61 6c 20 hed trimmed-tal
5610: 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 6c trimmed-reg regl
5620: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 en regfull)....(
5630: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
5640: 74 61 6c 20 74 72 69 6d 6d 65 64 2d 74 61 6c 20 tal trimmed-tal
5650: 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 6c trimmed-reg regl
5660: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 28 en regfull)....(
5670: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
5680: 72 65 67 20 74 72 69 6d 6d 65 64 2d 74 61 6c 20 reg trimmed-tal
5690: 74 72 69 6d 6d 65 64 2d 72 65 67 20 72 65 67 6c trimmed-reg regl
56a0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 72 en regfull)....r
56b0: 65 72 75 6e 73 29 29 29 0a 09 20 20 20 20 20 20 eruns)))..
56c0: 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 (list (car newta
56d0: 6c 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e l)(append (cdr n
56e0: 65 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 ewtal) reg) '()
56f0: 72 65 72 75 6e 73 29 29 29 29 0a 0a 20 20 20 20 reruns))))..
5700: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5710: 2d 69 6e 66 6f 20 31 20 22 61 6c 6c 69 6e 71 75 -info 1 "allinqu
5720: 65 75 65 3a 20 22 20 61 6c 6c 69 6e 71 75 65 75 eue: " allinqueu
5730: 65 29 0a 20 20 20 20 20 3b 3b 20 28 64 65 62 75 e). ;; (debu
5740: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
5750: 70 72 65 72 65 71 73 74 72 73 3a 20 22 20 70 72 prereqstrs: " pr
5760: 65 72 65 71 73 74 72 73 29 0a 20 20 20 20 20 3b ereqstrs). ;
5770: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ; (debug:print-i
5780: 6e 66 6f 20 31 20 22 6e 6f 74 69 6e 71 75 65 75 nfo 1 "notinqueu
5790: 65 3a 20 22 20 6e 6f 74 69 6e 71 75 65 75 65 29 e: " notinqueue)
57a0: 0a 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a . ;; (debug:
57b0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 74 61 print-info 1 "ta
57c0: 6c 3a 20 20 20 20 20 20 20 20 22 20 74 61 6c 29 l: " tal)
57d0: 0a 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a . ;; (debug:
57e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 65 print-info 1 "ne
57f0: 77 74 61 6c 3a 20 20 20 20 20 22 20 6e 65 77 74 wtal: " newt
5800: 61 6c 29 0a 20 20 20 20 20 3b 3b 20 28 64 65 62 al). ;; (deb
5810: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
5820: 22 72 65 67 3a 20 20 20 20 20 20 20 20 22 20 72 "reg: " r
5830: 65 67 29 0a 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 eg)..;; == ==
5840: 20 20 20 20 3b 3b 20 6e 75 6d 2d 72 65 74 72 69 ;; num-retri
5850: 65 73 20 63 6f 64 65 20 77 61 73 20 68 65 72 65 es code was here
5860: 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 .;; == ==
5870: 3b 3b 20 77 65 20 75 73 65 20 74 68 69 73 20 6f ;; we use this o
5880: 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 6d 6f pportunity to mo
5890: 76 65 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 72 ve contents of r
58a0: 65 67 20 74 6f 20 74 61 6c 0a 3b 3b 20 3d 3d 20 eg to tal.;; ==
58b0: 3d 3d 20 20 20 20 20 20 20 3b 3b 20 62 75 74 20 == ;; but
58c0: 61 6c 73 6f 20 6c 65 74 73 20 63 68 65 63 6b 20 also lets check
58d0: 74 68 61 74 20 74 68 65 20 70 72 65 72 65 71 75 that the prerequ
58e0: 69 73 69 74 65 73 20 61 72 65 20 61 6c 6c 20 69 isites are all i
58f0: 6e 20 74 68 65 20 6e 65 77 74 61 6c 20 6f 72 20 n the newtal or
5900: 72 65 72 75 6e 73 20 6c 69 73 74 73 0a 3b 3b 20 reruns lists.;;
5910: 3d 3d 20 3d 3d 20 0a 3b 3b 20 3d 3d 20 3d 3d 20 == == .;; == ==
5920: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 6c (let* ((al
5930: 6c 69 6e 71 75 65 75 65 20 28 6d 61 70 20 28 6c linqueue (map (l
5940: 61 6d 62 64 61 20 28 78 29 28 69 66 20 28 73 74 ambda (x)(if (st
5950: 72 69 6e 67 3f 20 78 29 20 78 20 28 64 62 3a 74 ring? x) x (db:t
5960: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
5970: 20 78 29 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 x))).;; == ==
5980: 20 20 20 20 20 20 20 09 09 20 20 20 20 20 20 28 .. (
5990: 61 70 70 65 6e 64 20 6e 65 77 74 61 6c 20 72 65 append newtal re
59a0: 72 75 6e 73 29 29 29 0a 3b 3b 20 3d 3d 20 3d 3d runs))).;; == ==
59b0: 20 09 20 20 20 20 20 3b 3b 20 70 72 65 72 65 71 . ;; prereq
59c0: 73 74 72 73 20 69 73 20 61 20 6c 69 73 74 20 6f strs is a list o
59d0: 66 20 74 65 73 74 20 6e 61 6d 65 73 20 61 73 20 f test names as
59e0: 73 74 72 69 6e 67 73 20 74 68 61 74 20 61 72 65 strings that are
59f0: 20 70 72 65 72 65 71 73 20 66 6f 72 20 68 65 64 prereqs for hed
5a00: 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 .;; == ==
5a10: 20 20 20 20 20 20 20 28 70 72 65 72 65 71 73 74 (prereqst
5a20: 72 73 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 rs (map (lambda
5a30: 28 78 29 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (x)(if (string?
5a40: 78 29 20 78 20 28 64 62 3a 74 65 73 74 2d 67 65 x) x (db:test-ge
5a50: 74 2d 74 65 73 74 6e 61 6d 65 20 78 29 29 29 0a t-testname x))).
5a60: 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 20 ;; == ==
5a70: 20 09 09 20 20 20 20 20 20 70 72 65 72 65 71 73 .. prereqs
5a80: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 3b 3b 20 3d 3d -not-met)).;; ==
5a90: 20 3d 3d 20 09 20 20 20 20 20 3b 3b 20 61 20 70 == . ;; a p
5aa0: 72 65 72 65 71 20 74 68 61 74 20 69 73 20 6e 6f rereq that is no
5ab0: 74 20 66 6f 75 6e 64 20 69 6e 20 61 6c 6c 69 6e t found in allin
5ac0: 71 75 65 75 65 20 77 69 6c 6c 20 62 65 20 70 75 queue will be pu
5ad0: 74 20 69 6e 20 74 68 65 20 6e 6f 74 69 6e 71 75 t in the notinqu
5ae0: 65 75 65 20 6c 69 73 74 0a 3b 3b 20 3d 3d 20 3d eue list.;; == =
5af0: 3d 20 09 20 20 20 20 20 3b 3b 20 0a 3b 3b 20 3d = . ;; .;; =
5b00: 3d 20 3d 3d 20 20 20 20 20 20 20 20 20 20 20 20 = ==
5b10: 20 20 28 6e 6f 74 69 6e 71 75 65 75 65 20 28 66 (notinqueue (f
5b20: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
5b30: 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 ).;; == ==
5b40: 20 20 20 09 09 09 20 20 20 28 6e 6f 74 20 28 6d ... (not (m
5b50: 65 6d 62 65 72 20 78 20 61 6c 6c 69 6e 71 75 65 ember x allinque
5b60: 75 65 29 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 ue))).;; == ==
5b70: 20 20 20 20 20 20 20 09 09 09 20 70 72 65 72 65 ... prere
5b80: 71 73 74 72 73 29 29 29 0a 3b 3b 20 3d 3d 20 3d qstrs))).;; == =
5b90: 3d 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e = (if (n
5ba0: 6f 74 20 28 6e 75 6c 6c 3f 20 6e 6f 74 69 6e 71 ot (null? notinq
5bb0: 75 65 75 65 29 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 ueue)).;; == ==
5bc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5bd0: 28 72 75 6e 73 3a 63 61 6e 2d 6b 65 65 70 2d 72 (runs:can-keep-r
5be0: 75 6e 6e 69 6e 67 3f 20 68 65 64 20 35 29 20 3b unning? hed 5) ;
5bf0: 3b 20 74 72 79 20 66 69 76 65 20 74 69 6d 65 73 ; try five times
5c00: 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 .;; == ==
5c10: 20 20 09 28 62 65 67 69 6e 0a 3b 3b 20 3d 3d 20 .(begin.;; ==
5c20: 3d 3d 20 09 09 20 20 28 64 65 62 75 67 3a 70 72 == .. (debug:pr
5c30: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 6e 63 72 int-info 4 "incr
5c40: 65 6d 65 6e 74 20 63 61 6e 74 2d 72 75 6e 2d 74 ement cant-run-t
5c50: 65 73 74 73 20 66 6f 72 20 22 20 68 65 64 29 0a ests for " hed).
5c60: 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 20 ;; == ==
5c70: 20 09 20 20 28 72 75 6e 73 3a 69 6e 63 2d 63 61 . (runs:inc-ca
5c80: 6e 74 2d 72 75 6e 2d 74 65 73 74 73 20 68 65 64 nt-run-tests hed
5c90: 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 ).;; == ==
5ca0: 20 20 20 09 20 20 28 6c 69 73 74 20 28 63 61 72 . (list (car
5cb0: 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e 64 20 newtal)(append
5cc0: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 (cdr newtal) reg
5cd0: 29 20 27 28 29 20 72 65 72 75 6e 73 29 29 0a 3b ) '() reruns)).;
5ce0: 3b 20 3d 3d 20 3d 3d 20 20 20 20 20 20 20 20 20 ; == ==
5cf0: 09 28 62 65 67 69 6e 0a 3b 3b 20 3d 3d 20 3d 3d .(begin.;; == ==
5d00: 20 09 09 20 20 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 .. .;; == == .
5d10: 09 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 . (if (runs:low
5d20: 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 6e 6f 20 noise (conc "no
5d30: 66 61 69 6c 73 20 70 72 65 72 65 71 2c 20 6e 75 fails prereq, nu
5d40: 6c 6c 20 6e 6f 74 69 6e 71 75 65 75 65 20 22 20 ll notinqueue "
5d50: 68 65 64 29 20 33 30 29 0a 3b 3b 20 3d 3d 20 3d hed) 30).;; == =
5d60: 3d 20 09 09 20 20 20 20 20 20 28 62 65 67 69 6e = .. (begin
5d70: 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 28 64 65 .;; == == ...(de
5d80: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 bug:print 1 "WAR
5d90: 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 68 65 64 NING: test " hed
5da0: 20 22 20 68 61 73 20 6e 6f 20 66 61 69 6c 65 64 " has no failed
5db0: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 62 prerequisites b
5dc0: 75 74 20 64 6f 65 73 20 68 61 76 65 20 70 72 65 ut does have pre
5dd0: 72 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 requistes that a
5de0: 72 65 20 4e 4f 54 20 69 6e 20 74 68 65 20 71 75 re NOT in the qu
5df0: 65 75 65 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 eue: " (string-i
5e00: 6e 74 65 72 73 70 65 72 73 65 20 6e 6f 74 69 6e ntersperse notin
5e10: 71 75 65 75 65 20 22 2c 20 22 29 29 0a 3b 3b 20 queue ", ")).;;
5e20: 3d 3d 20 3d 3d 20 09 09 09 28 64 65 62 75 67 3a == == ...(debug:
5e30: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 61 6c print-info 4 "al
5e40: 6c 69 6e 71 75 65 75 65 3a 20 22 20 61 6c 6c 69 linqueue: " alli
5e50: 6e 71 75 65 75 65 29 0a 3b 3b 20 3d 3d 20 3d 3d nqueue).;; == ==
5e60: 20 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ...(debug:print
5e70: 2d 69 6e 66 6f 20 34 20 22 70 72 65 72 65 71 73 -info 4 "prereqs
5e80: 74 72 73 3a 20 22 20 70 72 65 72 65 71 73 74 72 trs: " prereqstr
5e90: 73 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 28 s).;; == == ...(
5ea0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5eb0: 20 34 20 22 6e 6f 74 69 6e 71 75 65 75 65 3a 20 4 "notinqueue:
5ec0: 22 20 6e 6f 74 69 6e 71 75 65 75 65 29 29 29 0a " notinqueue))).
5ed0: 3b 3b 20 3d 3d 20 3d 3d 20 09 09 20 20 28 69 66 ;; == == .. (if
5ee0: 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 74 61 6c (and (null? tal
5ef0: 29 28 6e 75 6c 6c 3f 20 72 65 67 29 29 0a 3b 3b )(null? reg)).;;
5f00: 20 3d 3d 20 3d 3d 20 09 09 20 20 20 20 20 20 28 == == .. (
5f10: 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 6c list (car newtal
5f20: 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e 65 )(append (cdr ne
5f30: 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 72 wtal) reg) '() r
5f40: 65 72 75 6e 73 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 eruns).;; == ==
5f50: 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 72 .. (list (r
5f60: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
5f70: 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 ed tal reg regle
5f80: 6e 20 72 65 67 66 75 6c 6c 29 0a 3b 3b 20 3d 3d n regfull).;; ==
5f90: 20 3d 3d 20 09 09 09 20 20 20 20 28 72 75 6e 73 == ... (runs
5fa0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
5fb0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
5fc0: 65 67 66 75 6c 6c 29 0a 3b 3b 20 3d 3d 20 3d 3d egfull).;; == ==
5fd0: 20 09 09 09 20 20 20 20 28 72 75 6e 73 3a 71 75 ... (runs:qu
5fe0: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
5ff0: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
6000: 75 6c 6c 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 ull).;; == == ..
6010: 09 20 20 20 20 72 65 72 75 6e 73 29 29 29 29 0a . reruns)))).
6020: 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 20 20 3b 3b ;; == == . ;;
6030: 20 68 61 76 65 20 70 72 65 72 65 71 73 20 69 6e have prereqs in
6040: 20 71 75 65 75 65 2c 20 6b 65 65 70 20 67 6f 69 queue, keep goi
6050: 6e 67 2e 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 20 20 ng..;; == == .
6060: 20 20 28 62 65 67 69 6e 0a 3b 3b 20 3d 3d 20 3d (begin.;; == =
6070: 3d 20 09 20 20 20 20 20 20 28 69 66 20 28 72 75 = . (if (ru
6080: 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e ns:lownoise (con
6090: 63 20 22 6e 6f 20 66 61 69 6c 73 20 70 72 65 72 c "no fails prer
60a0: 65 71 20 22 20 68 65 64 29 20 33 30 29 0a 3b 3b eq " hed) 30).;;
60b0: 20 3d 3d 20 3d 3d 20 09 09 20 20 28 64 65 62 75 == == .. (debu
60c0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
60d0: 6e 6f 20 66 61 69 6c 73 20 69 6e 20 70 72 65 72 no fails in prer
60e0: 65 71 75 69 73 69 74 65 73 20 66 6f 72 20 22 20 equisites for "
60f0: 68 65 64 20 22 2c 20 77 61 69 74 69 6e 67 20 6f hed ", waiting o
6100: 6e 20 74 65 73 74 73 3b 20 22 0a 3b 3b 20 3d 3d n tests; ".;; ==
6110: 20 3d 3d 20 09 09 09 09 20 20 20 20 28 73 74 72 == .... (str
6120: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6130: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
6140: 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 09 09 09 09 .;; == == ......
6150: 09 20 20 20 20 20 20 20 28 69 66 20 28 73 74 72 . (if (str
6160: 69 6e 67 3f 20 78 29 0a 3b 3b 20 3d 3d 20 3d 3d ing? x).;; == ==
6170: 20 09 09 09 09 09 09 09 09 20 20 20 78 0a 3b 3b ........ x.;;
6180: 20 3d 3d 20 3d 3d 20 09 09 09 09 09 09 09 09 20 == == ........
6190: 20 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c (runs:make-ful
61a0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a l-test-name (db:
61b0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
61c0: 65 20 78 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 e x).;; == == ..
61d0: 09 09 09 09 09 09 09 09 09 20 20 20 20 20 28 64 ......... (d
61e0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
61f0: 70 61 74 68 20 78 29 29 29 29 0a 3b 3b 20 3d 3d path x)))).;; ==
6200: 20 3d 3d 20 09 09 09 09 09 09 09 20 20 20 20 20 == .......
6210: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 20 22 non-completed) "
6220: 2c 20 22 29 0a 3b 3b 20 3d 3d 20 3d 3d 20 09 09 , ").;; == == ..
6230: 09 09 20 20 20 20 22 2e 20 44 65 6c 61 79 69 6e .. ". Delayin
6240: 67 20 6c 61 75 6e 63 68 20 6f 66 20 22 20 68 65 g launch of " he
6250: 64 20 22 2e 22 29 29 0a 3b 3b 20 3d 3d 20 3d 3d d ".")).;; == ==
6260: 20 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 . (list (c
6270: 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e ar newtal)(appen
6280: 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 d (cdr newtal) r
6290: 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 29 eg) '() reruns))
62a0: 29 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 20 ))) ;; an issue
62b0: 77 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f 74 with prereqs not
62c0: 20 79 65 74 20 6d 65 74 3f 0a 0a 20 20 20 20 20 yet met?..
62d0: 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 66 61 69 ((and (null? fai
62e0: 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c 3f 20 6e ls).. (null? n
62f0: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 0a 20 on-completed)).
6300: 20 20 20 20 20 28 69 66 20 20 28 72 75 6e 73 3a (if (runs:
6310: 63 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 can-keep-running
6320: 3f 20 68 65 64 20 35 29 0a 09 20 20 28 62 65 67 ? hed 5).. (beg
6330: 69 6e 0a 09 20 20 20 20 28 72 75 6e 73 3a 69 6e in.. (runs:in
6340: 63 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 c-cant-run-tests
6350: 20 68 65 64 29 0a 09 20 20 20 20 28 64 65 62 75 hed).. (debu
6360: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
6370: 6e 6f 20 66 61 69 6c 73 20 69 6e 20 70 72 65 72 no fails in prer
6380: 65 71 75 69 73 69 74 65 73 20 66 6f 72 20 22 20 equisites for "
6390: 68 65 64 20 22 20 62 75 74 20 61 6c 73 6f 20 6e hed " but also n
63a0: 6f 6e 65 20 72 75 6e 6e 69 6e 67 2c 20 6b 65 65 one running, kee
63b0: 70 69 6e 67 20 22 20 68 65 64 20 22 20 66 6f 72 ping " hed " for
63c0: 20 6e 6f 77 2e 20 54 72 79 20 63 6f 75 6e 74 3a now. Try count:
63d0: 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 " (hash-table-r
63e0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e ef/default *seen
63f0: 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a -cant-run-tests*
6400: 20 68 65 64 20 30 29 29 0a 09 20 20 20 20 3b 3b hed 0)).. ;;
6410: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 63 6f 64 num-retries cod
6420: 65 20 77 61 73 20 68 65 72 65 0a 09 20 20 20 20 e was here..
6430: 3b 3b 20 77 65 20 75 73 65 20 74 68 69 73 20 6f ;; we use this o
6440: 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 6d 6f pportunity to mo
6450: 76 65 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 72 ve contents of r
6460: 65 67 20 74 6f 20 74 61 6c 0a 09 20 20 20 20 28 eg to tal.. (
6470: 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 6c list (car newtal
6480: 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e 65 )(append (cdr ne
6490: 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 72 wtal) reg) '() r
64a0: 65 72 75 6e 73 29 29 20 3b 3b 20 61 6e 20 69 73 eruns)) ;; an is
64b0: 73 75 65 20 77 69 74 68 20 70 72 65 72 65 71 73 sue with prereqs
64c0: 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 20 not yet met?..
64d0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 (begin.. (de
64e0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
64f0: 20 22 6e 6f 20 66 61 69 6c 73 20 69 6e 20 70 72 "no fails in pr
6500: 65 72 65 71 75 69 73 69 74 65 73 20 66 6f 72 20 erequisites for
6510: 22 20 68 65 64 20 22 20 62 75 74 20 6e 6f 74 68 " hed " but noth
6520: 69 6e 67 20 73 65 65 6e 20 72 75 6e 6e 69 6e 67 ing seen running
6530: 20 69 6e 20 61 20 77 68 69 6c 65 2c 20 64 72 6f in a while, dro
6540: 70 70 69 6e 67 20 74 65 73 74 20 22 20 68 65 64 pping test " hed
6550: 20 22 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 20 " from the run
6560: 71 75 65 75 65 22 29 0a 09 20 20 20 20 28 6c 69 queue").. (li
6570: 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e st (runs:queue-n
6580: 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 ext-hed tal reg
6590: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
65a0: 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d .. (runs:queue-
65b0: 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 next-tal tal reg
65c0: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
65d0: 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 ... (runs:queue
65e0: 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 -next-reg tal re
65f0: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
6600: 29 0a 09 09 20 20 72 65 72 75 6e 73 29 29 29 29 )... reruns))))
6610: 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f .. ((and (no
6620: 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 t (null? fails))
6630: 28 6d 65 6d 62 65 72 20 27 6e 6f 72 6d 61 6c 20 (member 'normal
6640: 74 65 73 74 6d 6f 64 65 29 29 0a 20 20 20 20 20 testmode)).
6650: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
6660: 66 6f 20 31 20 22 74 65 73 74 20 22 20 20 68 65 fo 1 "test " he
6670: 64 20 22 20 28 6d 6f 64 65 3d 22 20 74 65 73 74 d " (mode=" test
6680: 6d 6f 64 65 20 22 29 20 68 61 73 20 66 61 69 6c mode ") has fail
6690: 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 28 ed prerequisite(
66a0: 73 29 3b 20 22 0a 09 09 09 28 73 74 72 69 6e 67 s); "....(string
66b0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
66c0: 70 20 28 6c 61 6d 62 64 61 20 28 74 29 28 63 6f p (lambda (t)(co
66d0: 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nc (db:test-get-
66e0: 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 testname t) ":"
66f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
6700: 74 65 20 74 29 22 2f 22 28 64 62 3a 74 65 73 74 te t)"/"(db:test
6710: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 -get-status t)))
6720: 20 66 61 69 6c 73 29 20 22 2c 20 22 29 0a 09 09 fails) ", ")...
6730: 09 22 2c 20 72 65 6d 6f 76 69 6e 67 20 69 74 20 .", removing it
6740: 66 72 6f 6d 20 74 6f 2d 64 6f 20 6c 69 73 74 22 from to-do list"
6750: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 ). (if (or
6760: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (not (null? reg)
6770: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c )(not (null? tal
6780: 29 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 ))).. (begin..
6790: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
67a0: 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
67b0: 79 20 68 65 64 20 27 43 41 4e 4e 4f 54 52 55 4e y hed 'CANNOTRUN
67c0: 29 0a 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 ).. (list (ru
67d0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
67e0: 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e d tal reg reglen
67f0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 28 72 regfull)... (r
6800: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 uns:queue-next-t
6810: 61 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 al tal reg regle
6820: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 28 n regfull)... (
6830: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
6840: 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c reg tal reg regl
6850: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 20 20 en regfull)...
6860: 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 (cons hed reruns
6870: 29 29 29 0a 09 20 20 23 66 29 29 20 3b 3b 20 23 ))).. #f)) ;; #
6880: 66 20 66 6c 61 67 73 20 64 6f 20 6e 6f 74 20 6c f flags do not l
6890: 6f 6f 70 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 oop.. ((and
68a0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (not (null? fail
68b0: 73 29 29 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c s))(member 'topl
68c0: 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 29 0a evel testmode)).
68d0: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
68e0: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 28 ot (null? reg))(
68f0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
6900: 29 0a 09 20 20 20 28 6c 69 73 74 20 28 63 61 72 ).. (list (car
6910: 20 6e 65 77 74 61 6c 29 28 61 70 70 65 6e 64 20 newtal)(append
6920: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 (cdr newtal) reg
6930: 29 20 27 28 29 20 72 65 72 75 6e 73 29 0a 09 20 ) '() reruns)..
6940: 20 23 66 29 29 20 0a 20 20 20 20 20 28 65 6c 73 #f)) . (els
6950: 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 e. (debug:p
6960: 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a rint 1 "WARNING:
6970: 20 46 41 49 4c 53 20 6f 72 20 69 6e 63 6f 6d 70 FAILS or incomp
6980: 6c 65 74 65 20 74 65 73 74 73 20 61 72 65 20 70 lete tests are p
6990: 72 65 76 65 6e 74 69 6e 67 20 63 6f 6d 70 6c 65 reventing comple
69a0: 74 69 6f 6e 20 6f 66 20 74 68 69 73 20 72 75 6e tion of this run
69b0: 2e 20 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 . Dropping test
69c0: 22 20 68 65 64 20 22 20 66 72 6f 6d 20 74 68 65 " hed " from the
69d0: 20 72 75 6e 20 71 75 65 75 65 22 29 0a 20 20 20 run queue").
69e0: 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 (list (runs:q
69f0: 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 ueue-next-hed ta
6a00: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
6a10: 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 full)...(runs:qu
6a20: 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c eue-next-tal tal
6a30: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
6a40: 75 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 ull)...(runs:que
6a50: 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 ue-next-reg tal
6a60: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
6a70: 6c 6c 29 0a 09 09 72 65 72 75 6e 73 29 29 29 29 ll)...reruns))))
6a80: 29 20 3b 3b 20 28 6c 69 73 74 20 28 63 61 72 20 ) ;; (list (car
6a90: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
6aa0: 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 al) reg reruns))
6ab0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
6ac0: 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 2d 74 65 ns:mixed-list-te
6ad0: 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 73 74 72 stname-and-testr
6ae0: 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 69 ec->list-of-stri
6af0: 6e 67 73 20 69 6e 6c 73 74 29 0a 20 20 28 6d 61 ngs inlst). (ma
6b00: 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 p (lambda (t)..
6b10: 28 63 6f 6e 64 0a 09 20 20 28 28 76 65 63 74 6f (cond.. ((vecto
6b20: 72 3f 20 74 29 0a 09 20 20 20 28 63 6f 6e 63 20 r? t).. (conc
6b30: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
6b40: 74 65 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 te t) "/" (db:te
6b50: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 st-get-status t)
6b60: 29 29 0a 09 20 20 28 28 73 74 72 69 6e 67 3f 20 )).. ((string?
6b70: 74 29 0a 09 20 20 20 74 29 0a 09 20 20 28 65 6c t).. t).. (el
6b80: 73 65 20 0a 09 20 20 20 28 63 6f 6e 63 20 74 29 se .. (conc t)
6b90: 29 29 29 0a 20 20 20 20 20 20 20 69 6e 6c 73 74 ))). inlst
6ba0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
6bb0: 73 3a 70 72 6f 63 65 73 73 2d 65 78 70 61 6e 64 s:process-expand
6bc0: 65 64 2d 74 65 73 74 73 20 68 65 64 20 74 61 6c ed-tests hed tal
6bd0: 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 67 6c reg reruns regl
6be0: 65 6e 20 72 65 67 66 75 6c 6c 20 74 65 73 74 2d en regfull test-
6bf0: 72 65 63 6f 72 64 20 72 75 6e 6e 61 6d 65 20 74 record runname t
6c00: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
6c10: 74 68 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d th jobgroup max-
6c20: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
6c30: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 run-id waitons i
6c40: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f 64 tem-path testmod
6c50: 65 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 71 e test-patts req
6c60: 75 69 72 65 64 2d 74 65 73 74 73 20 74 65 73 74 uired-tests test
6c70: 2d 72 65 67 69 73 74 72 79 20 72 65 67 69 73 74 -registry regist
6c80: 72 79 2d 6d 75 74 65 78 20 66 6c 61 67 73 20 6b ry-mutex flags k
6c90: 65 79 76 61 6c 73 20 72 75 6e 2d 69 6e 66 6f 20 eyvals run-info
6ca0: 6e 65 77 74 61 6c 20 61 6c 6c 2d 74 65 73 74 73 newtal all-tests
6cb0: 2d 72 65 67 69 73 74 72 79 29 0a 20 20 28 6c 65 -registry). (le
6cc0: 74 2a 20 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d t* ((run-limits-
6cd0: 69 6e 66 6f 20 20 20 20 20 20 20 20 20 28 72 75 info (ru
6ce0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
6cf0: 74 65 73 74 73 20 6a 6f 62 67 72 6f 75 70 20 6d tests jobgroup m
6d00: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
6d10: 62 73 29 29 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 bs)) ;; look at
6d20: 74 68 65 20 74 65 73 74 20 6a 6f 62 67 72 6f 75 the test jobgrou
6d30: 70 20 61 6e 64 20 74 6f 74 20 6a 6f 62 73 20 72 p and tot jobs r
6d40: 75 6e 6e 69 6e 67 0a 09 20 28 68 61 76 65 2d 72 unning.. (have-r
6d50: 65 73 6f 75 72 63 65 73 20 20 20 20 20 20 20 20 esources
6d60: 20 20 28 63 61 72 20 72 75 6e 2d 6c 69 6d 69 74 (car run-limit
6d70: 73 2d 69 6e 66 6f 29 29 0a 09 20 28 6e 75 6d 2d s-info)).. (num-
6d80: 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 20 running
6d90: 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 (list-ref ru
6da0: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 31 29 n-limits-info 1)
6db0: 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 ).. (num-running
6dc0: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 6c 69 -in-jobgroup (li
6dd0: 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 st-ref run-limit
6de0: 73 2d 69 6e 66 6f 20 32 29 29 20 0a 09 20 28 6d s-info 2)) .. (m
6df0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
6e00: 62 73 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 bs (list-ref
6e10: 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f run-limits-info
6e20: 20 33 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 3)).. (job-grou
6e30: 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 p-limit
6e40: 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 (list-ref run-li
6e50: 6d 69 74 73 2d 69 6e 66 6f 20 34 29 29 0a 09 20 mits-info 4))..
6e60: 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 (prereqs-not-met
6e70: 20 20 20 20 20 20 20 20 20 28 6d 74 3a 6c 61 7a (mt:laz
6e80: 79 2d 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f y-get-prereqs-no
6e90: 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 t-met run-id wai
6ea0: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d tons item-path m
6eb0: 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a ode: testmode)).
6ec0: 09 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 . (fails
6ed0: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
6ee0: 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 :calc-fails prer
6ef0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 eqs-not-met))..
6f00: 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 (non-completed
6f10: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 (runs:c
6f20: 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 alc-not-complete
6f30: 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 d prereqs-not-me
6f40: 74 29 29 0a 09 20 28 6c 6f 6f 70 2d 6c 69 73 74 t)).. (loop-list
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6f60: 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 list hed tal reg
6f70: 20 72 65 72 75 6e 73 29 29 29 0a 20 20 20 20 28 reruns))). (
6f80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6f90: 20 34 20 22 68 61 76 65 2d 72 65 73 6f 75 72 63 4 "have-resourc
6fa0: 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f 75 es: " have-resou
6fb0: 72 63 65 73 20 22 20 70 72 65 72 65 71 73 2d 6e rces " prereqs-n
6fc0: 6f 74 2d 6d 65 74 3a 20 28 22 20 0a 09 09 20 20 ot-met: (" ...
6fd0: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
6fe0: 72 73 70 65 72 73 65 20 0a 09 09 20 20 20 20 20 rsperse ...
6ff0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
7000: 74 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 t).... (if
7010: 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 (vector? t).....
7020: 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 (conc (db:test
7030: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
7040: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
7050: 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 20 20 tatus t)).....
7060: 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a (conc " WARNING:
7070: 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 t is not a vect
7080: 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 20 20 or=" t )))....
7090: 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 prereqs-not-me
70a0: 74 29 20 22 2c 20 22 29 20 22 29 20 66 61 69 6c t) ", ") ") fail
70b0: 73 3a 20 22 20 66 61 69 6c 73 29 0a 20 20 20 20 s: " fails).
70c0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e . (if (not (n
70d0: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
70e0: 2d 6d 65 74 29 29 0a 09 28 64 65 62 75 67 3a 70 -met))..(debug:p
70f0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 77 61 69 rint-info 1 "wai
7100: 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 3b 20 22 ting on tests; "
7110: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7120: 65 72 73 65 20 28 72 75 6e 73 3a 6d 69 78 65 64 erse (runs:mixed
7130: 2d 6c 69 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 -list-testname-a
7140: 6e 64 2d 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 nd-testrec->list
7150: 2d 6f 66 2d 73 74 72 69 6e 67 73 20 70 72 65 72 -of-strings prer
7160: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 eqs-not-met) ",
7170: 22 29 29 29 0a 0a 20 20 20 20 3b 3b 20 44 6f 6e "))).. ;; Don
7180: 27 74 20 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 't know at this
7190: 74 69 6d 65 20 69 66 20 74 68 65 20 74 65 73 74 time if the test
71a0: 20 68 61 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 have been launc
71b0: 68 65 64 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 hed at some time
71c0: 20 69 6e 20 74 68 65 20 70 61 73 74 0a 20 20 20 in the past.
71d0: 20 3b 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 73 ;; i.e. is this
71e0: 20 61 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 20 20 a re-launch?.
71f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7200: 6e 66 6f 20 34 20 22 72 75 6e 2d 6c 69 6d 69 74 nfo 4 "run-limit
7210: 73 2d 69 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c s-info = " run-l
7220: 69 6d 69 74 73 2d 69 6e 66 6f 29 0a 20 20 20 20 imits-info).
7230: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
7240: 0a 20 20 20 20 20 3b 3b 20 43 68 65 63 6b 20 69 . ;; Check i
7250: 74 65 6d 20 70 61 74 68 20 61 67 61 69 6e 73 74 tem path against
7260: 20 69 74 65 6d 2d 70 61 74 74 73 2c 20 0a 20 20 item-patts, .
7270: 20 20 20 3b 3b 0a 20 20 20 20 20 28 28 6e 6f 74 ;;. ((not
7280: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
7290: 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 3a st-patts (tests:
72a0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
72b0: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
72c0: 72 64 29 20 69 74 65 6d 2d 70 61 74 68 20 72 65 rd) item-path re
72d0: 71 75 69 72 65 64 3a 20 72 65 71 75 69 72 65 64 quired: required
72e0: 2d 74 65 73 74 73 29 29 20 3b 3b 20 54 68 69 73 -tests)) ;; This
72f0: 20 74 65 73 74 2f 69 74 65 6d 70 61 74 68 20 69 test/itempath i
7300: 73 20 6e 6f 74 20 74 6f 20 62 65 20 72 75 6e 0a s not to be run.
7310: 20 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 74 68 ;; else th
7320: 65 20 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 e run is stuck,
7330: 74 65 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 temporarily or p
7340: 65 72 6d 61 6e 65 6e 74 6c 79 0a 20 20 20 20 20 ermanently.
7350: 20 3b 3b 20 62 75 74 20 73 68 6f 75 6c 64 20 63 ;; but should c
7360: 68 65 63 6b 20 69 66 20 69 74 20 69 73 20 64 75 heck if it is du
7370: 65 20 74 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 e to lack of res
7380: 6f 75 72 63 65 73 20 76 73 2e 20 70 72 65 72 65 ources vs. prere
7390: 71 75 69 73 69 74 65 73 0a 20 20 20 20 20 20 28 quisites. (
73a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
73b0: 20 31 20 22 53 6b 69 70 70 69 6e 67 20 22 20 28 1 "Skipping " (
73c0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
73d0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
73e0: 74 2d 72 65 63 6f 72 64 29 20 22 20 22 20 69 74 t-record) " " it
73f0: 65 6d 2d 70 61 74 68 20 22 20 61 73 20 69 74 20 em-path " as it
7400: 64 6f 65 73 6e 27 74 20 6d 61 74 63 68 20 22 20 doesn't match "
7410: 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 test-patts).
7420: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
7430: 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 null? tal))(not
7440: 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 0a 09 20 (null? reg)))..
7450: 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 (list (runs:que
7460: 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 ue-next-hed tal
7470: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
7480: 6c 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 ll)...(runs:queu
7490: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
74a0: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
74b0: 6c 29 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 l)...(runs:queue
74c0: 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 -next-reg tal re
74d0: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
74e0: 29 0a 09 09 72 65 72 75 6e 73 29 0a 09 20 20 23 )...reruns).. #
74f0: 66 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b f)). . ;
7500: 3b 20 52 65 67 69 73 74 65 72 20 74 65 73 74 73 ; Register tests
7510: 20 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 . ;;. (
7520: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
7530: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
7540: 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 t-registry (runs
7550: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
7560: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
7570: 74 65 6d 2d 70 61 74 68 29 20 23 66 29 29 0a 20 tem-path) #f)).
7580: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7590: 74 2d 69 6e 66 6f 20 34 20 22 50 72 65 2d 72 65 t-info 4 "Pre-re
75a0: 67 69 73 74 65 72 69 6e 67 20 74 65 73 74 20 22 gistering test "
75b0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
75c0: 74 65 6d 2d 70 61 74 68 20 22 20 74 6f 20 63 72 tem-path " to cr
75d0: 65 61 74 65 20 70 6c 61 63 65 68 6f 6c 64 65 72 eate placeholder
75e0: 22 20 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 " ). (if (e
75f0: 71 3f 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 q? *transport-ty
7600: 70 65 2a 20 27 66 73 29 20 3b 3b 20 6e 6f 20 70 pe* 'fs) ;; no p
7610: 6f 69 6e 74 20 69 6e 20 70 61 72 61 6c 6c 65 6c oint in parallel
7620: 20 72 65 67 69 73 74 72 61 74 69 6f 6e 20 69 66 registration if
7630: 20 75 73 65 20 66 73 0a 09 20 20 28 62 65 67 69 use fs.. (begi
7640: 6e 0a 09 20 20 20 20 28 63 64 62 3a 74 65 73 74 n.. (cdb:test
7650: 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 s-register-test
7660: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d *runremote* run-
7670: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
7680: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 28 68 61 m-path).. (ha
7690: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
76a0: 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 75 6e st-registry (run
76b0: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
76c0: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
76d0: 69 74 65 6d 2d 70 61 74 68 29 20 27 64 6f 6e 65 item-path) 'done
76e0: 29 29 0a 09 20 20 28 6c 65 74 20 28 28 74 68 20 )).. (let ((th
76f0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
7700: 6d 62 64 61 20 28 29 0a 09 09 09 09 20 20 20 28 mbda ()..... (
7710: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 72 65 67 69 mutex-lock! regi
7720: 73 74 72 79 2d 6d 75 74 65 78 29 0a 09 09 09 09 stry-mutex).....
7730: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
7740: 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
7750: 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c y (runs:make-ful
7760: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
7770: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
7780: 20 27 73 74 61 72 74 29 0a 09 09 09 09 20 20 20 'start).....
7790: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 (mutex-unlock! r
77a0: 65 67 69 73 74 72 79 2d 6d 75 74 65 78 29 0a 09 egistry-mutex)..
77b0: 09 09 09 20 20 20 3b 3b 20 49 66 20 68 61 76 65 ... ;; If have
77c0: 6e 27 74 20 64 6f 6e 65 20 69 74 20 62 65 66 6f n't done it befo
77d0: 72 65 20 72 65 67 69 73 74 65 72 20 61 20 74 6f re register a to
77e0: 70 20 6c 65 76 65 6c 20 74 65 73 74 20 69 66 20 p level test if
77f0: 74 68 69 73 20 69 73 20 61 6e 20 69 74 65 6d 69 this is an itemi
7800: 7a 65 64 20 74 65 73 74 0a 09 09 09 09 20 20 20 zed test.....
7810: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 68 (if (not (eq? (h
7820: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7830: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 fault test-regis
7840: 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 try (runs:make-f
7850: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
7860: 73 74 2d 6e 61 6d 65 20 22 22 29 20 23 66 29 20 st-name "") #f)
7870: 27 64 6f 6e 65 29 29 0a 09 09 09 09 20 20 20 20 'done)).....
7880: 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 65 (cdb:tests-re
7890: 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 6e gister-test *run
78a0: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 remote* run-id t
78b0: 65 73 74 2d 6e 61 6d 65 20 22 22 29 29 0a 09 09 est-name ""))...
78c0: 09 09 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d .. (cdb:tests-
78d0: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 register-test *r
78e0: 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 unremote* run-id
78f0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
7900: 70 61 74 68 29 0a 09 09 09 09 20 20 20 28 6d 75 path)..... (mu
7910: 74 65 78 2d 6c 6f 63 6b 21 20 72 65 67 69 73 74 tex-lock! regist
7920: 72 79 2d 6d 75 74 65 78 29 0a 09 09 09 09 20 20 ry-mutex).....
7930: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
7940: 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
7950: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
7960: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
7970: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 ame item-path) '
7980: 64 6f 6e 65 29 0a 09 09 09 09 20 20 20 28 6d 75 done)..... (mu
7990: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 tex-unlock! regi
79a0: 73 74 72 79 2d 6d 75 74 65 78 29 29 0a 09 09 09 stry-mutex))....
79b0: 09 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d . (conc test-nam
79c0: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
79d0: 29 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 ))).. (thread
79e0: 2d 73 74 61 72 74 21 20 74 68 29 29 29 0a 20 20 -start! th))).
79f0: 20 20 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b (runs:shrink
7a00: 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 -can-run-more-te
7a10: 73 74 73 2d 63 6f 75 6e 74 29 20 20 20 3b 3b 20 sts-count) ;;
7a20: 44 45 4c 41 59 20 54 57 45 41 4b 45 52 20 28 73 DELAY TWEAKER (s
7a30: 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 till needed?).
7a40: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 (if (and (nu
7a50: 6c 6c 3f 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 ll? tal)(null? r
7a60: 65 67 29 29 0a 09 20 20 28 6c 69 73 74 20 68 65 eg)).. (list he
7a70: 64 20 74 61 6c 20 28 61 70 70 65 6e 64 20 72 65 d tal (append re
7a80: 67 20 28 6c 69 73 74 20 68 65 64 29 29 20 72 65 g (list hed)) re
7a90: 72 75 6e 73 29 0a 09 20 20 28 6c 69 73 74 20 28 runs).. (list (
7aa0: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
7ab0: 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c hed tal reg regl
7ac0: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 en regfull)...(r
7ad0: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 uns:queue-next-t
7ae0: 61 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 al tal reg regle
7af0: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 3b 3b 20 n regfull)...;;
7b00: 4e 42 2f 2f 20 48 65 72 65 20 77 65 20 61 72 65 NB// Here we are
7b10: 20 62 75 69 6c 64 69 6e 67 20 72 65 67 20 61 73 building reg as
7b20: 20 77 65 20 72 65 67 69 73 74 65 72 20 74 65 73 we register tes
7b30: 74 73 0a 09 09 3b 3b 20 69 66 20 72 65 67 66 75 ts...;; if regfu
7b40: 6c 6c 20 77 65 20 6d 75 73 74 20 70 6f 70 20 74 ll we must pop t
7b50: 68 65 20 66 72 6f 6e 74 20 69 74 65 6d 20 6f 66 he front item of
7b60: 66 20 72 65 67 0a 09 09 28 69 66 20 72 65 67 66 f reg...(if regf
7b70: 75 6c 6c 0a 09 09 20 20 20 20 28 61 70 70 65 6e ull... (appen
7b80: 64 20 28 63 64 72 20 72 65 67 29 20 28 6c 69 73 d (cdr reg) (lis
7b90: 74 20 68 65 64 29 29 0a 09 09 20 20 20 20 28 61 t hed))... (a
7ba0: 70 70 65 6e 64 20 72 65 67 20 28 6c 69 73 74 20 ppend reg (list
7bb0: 68 65 64 29 29 29 0a 09 09 72 65 72 75 6e 73 29 hed)))...reruns)
7bc0: 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b )). . ;;
7bd0: 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 68 At this point h
7be0: 65 64 20 74 65 73 74 20 72 65 67 69 73 74 72 61 ed test registra
7bf0: 74 69 6f 6e 20 6d 75 73 74 20 62 65 20 63 6f 6d tion must be com
7c00: 70 6c 65 74 65 64 2e 0a 20 20 20 20 20 3b 3b 0a pleted.. ;;.
7c10: 20 20 20 20 20 28 28 65 71 3f 20 28 68 61 73 68 ((eq? (hash
7c20: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7c30: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 lt test-registry
7c40: 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c (runs:make-full
7c50: 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d -test-name test-
7c60: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 name item-path)
7c70: 23 66 29 0a 09 20 20 20 27 73 74 61 72 74 29 0a #f).. 'start).
7c80: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7c90: 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 74 69 nt-info 0 "Waiti
7ca0: 6e 67 20 6f 6e 20 74 65 73 74 20 72 65 67 69 73 ng on test regis
7cb0: 74 72 61 74 69 6f 6e 28 73 29 3a 20 22 0a 09 09 tration(s): "...
7cc0: 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 .(string-intersp
7cd0: 65 72 73 65 20 0a 09 09 09 20 28 66 69 6c 74 65 erse .... (filte
7ce0: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
7cf0: 09 09 20 20 20 28 65 71 3f 20 28 68 61 73 68 2d .. (eq? (hash-
7d00: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7d10: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
7d20: 78 20 23 66 29 20 27 73 74 61 72 74 29 29 0a 09 x #f) 'start))..
7d30: 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ... (hash-table-
7d40: 6b 65 79 73 20 74 65 73 74 2d 72 65 67 69 73 74 keys test-regist
7d50: 72 79 29 29 0a 09 09 09 20 22 2c 20 22 29 29 0a ry)).... ", ")).
7d60: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
7d70: 65 65 70 21 20 30 2e 31 29 0a 20 20 20 20 20 20 eep! 0.1).
7d80: 28 6c 69 73 74 20 68 65 64 20 74 61 6c 20 72 65 (list hed tal re
7d90: 67 20 72 65 72 75 6e 73 29 29 0a 20 20 20 20 20 g reruns)).
7da0: 0a 20 20 20 20 20 3b 3b 20 49 66 20 6e 6f 20 72 . ;; If no r
7db0: 65 73 6f 75 72 63 65 73 20 61 72 65 20 61 76 61 esources are ava
7dc0: 69 6c 61 62 6c 65 20 6a 75 73 74 20 6b 69 6c 6c ilable just kill
7dd0: 20 74 69 6d 65 20 61 6e 64 20 6c 6f 6f 70 20 61 time and loop a
7de0: 67 61 69 6e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 gain. ;;.
7df0: 20 20 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 ((not have-res
7e00: 6f 75 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c ources) ;; simpl
7e10: 79 20 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 y try again afte
7e20: 72 20 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f r waiting a seco
7e30: 6e 64 0a 20 20 20 20 20 20 28 69 66 20 28 72 75 nd. (if (ru
7e40: 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 6e 6f 20 ns:lownoise "no
7e50: 72 65 73 6f 75 72 63 65 73 22 20 36 30 29 0a 09 resources" 60)..
7e60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7e70: 6e 66 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 nfo 1 "no resour
7e80: 63 65 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 ces to run new t
7e90: 65 73 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e ests, waiting ..
7ea0: 2e 22 29 29 0a 20 20 20 20 20 20 3b 3b 20 48 61 .")). ;; Ha
7eb0: 76 65 20 67 6f 6e 65 20 62 61 63 6b 20 61 6e 64 ve gone back and
7ec0: 20 66 6f 72 74 68 20 6f 6e 20 74 68 69 73 20 62 forth on this b
7ed0: 75 74 20 64 62 20 73 74 61 72 76 61 74 69 6f 6e ut db starvation
7ee0: 20 69 73 20 61 6e 20 69 73 73 75 65 2e 0a 20 20 is an issue..
7ef0: 20 20 20 20 3b 3b 20 77 61 69 74 20 6f 6e 65 20 ;; wait one
7f00: 73 65 63 6f 6e 64 20 62 65 66 6f 72 65 20 6c 6f second before lo
7f10: 6f 6b 69 6e 67 20 61 67 61 69 6e 20 74 6f 20 72 oking again to r
7f20: 75 6e 20 6a 6f 62 73 2e 0a 20 20 20 20 20 20 28 un jobs.. (
7f30: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
7f40: 0a 20 20 20 20 20 20 3b 3b 20 63 6f 75 6c 64 20 . ;; could
7f50: 68 61 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 have done hed ta
7f60: 6c 20 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 l here but doing
7f70: 20 63 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 car/cdr of newt
7f80: 61 6c 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 al to rotate tes
7f90: 74 73 0a 20 20 20 20 20 20 28 6c 69 73 74 20 28 ts. (list (
7fa0: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
7fb0: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
7fc0: 6e 73 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 ns)). .
7fd0: 3b 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 66 ;; This is the f
7fe0: 69 6e 61 6c 20 73 74 61 67 65 2c 20 65 76 65 72 inal stage, ever
7ff0: 79 74 68 69 6e 67 20 69 73 20 69 6e 20 70 6c 61 ything is in pla
8000: 63 65 20 73 6f 20 6c 61 75 6e 63 68 20 74 68 65 ce so launch the
8010: 20 74 65 73 74 0a 20 20 20 20 20 3b 3b 0a 20 20 test. ;;.
8020: 20 20 20 28 28 61 6e 64 20 68 61 76 65 2d 72 65 ((and have-re
8030: 73 6f 75 72 63 65 73 0a 09 20 20 20 28 6f 72 20 sources.. (or
8040: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n
8050: 6f 74 2d 6d 65 74 29 0a 09 20 20 20 20 20 20 20 ot-met)..
8060: 28 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f (and (eq? testmo
8070: 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 de 'toplevel)...
8080: 20 20 20 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 (null? non-c
8090: 6f 6d 70 6c 65 74 65 64 29 29 29 29 0a 20 20 20 ompleted)))).
80a0: 20 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c ;; (hash-tabl
80b0: 65 2d 64 65 6c 65 74 65 21 20 2a 6d 61 78 2d 74 e-delete! *max-t
80c0: 72 69 65 73 2d 68 61 73 68 2a 20 28 72 75 6e 73 ries-hash* (runs
80d0: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
80e0: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
80f0: 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 tem-path)).
8100: 20 3b 3b 20 77 65 20 61 72 65 20 67 6f 69 6e 67 ;; we are going
8110: 20 74 6f 20 72 65 73 65 74 20 61 6c 6c 20 74 68 to reset all th
8120: 65 20 63 6f 75 6e 74 65 72 73 20 66 6f 72 20 74 e counters for t
8130: 65 73 74 20 72 65 74 72 69 65 73 20 62 79 20 73 est retries by s
8140: 65 74 74 69 6e 67 20 61 20 6e 65 77 20 68 61 73 etting a new has
8150: 68 20 74 61 62 6c 65 0a 20 20 20 20 20 20 3b 3b h table. ;;
8160: 20 74 68 69 73 20 6d 65 61 6e 73 20 74 68 65 79 this means they
8170: 20 77 69 6c 6c 20 69 6e 63 72 65 6d 65 6e 74 20 will increment
8180: 6f 6e 6c 79 20 77 68 65 6e 20 6e 6f 74 68 69 6e only when nothin
8190: 67 20 63 61 6e 20 62 65 20 72 75 6e 0a 20 20 20 g can be run.
81a0: 20 20 20 28 73 65 74 21 20 2a 6d 61 78 2d 74 72 (set! *max-tr
81b0: 69 65 73 2d 68 61 73 68 2a 20 28 6d 61 6b 65 2d ies-hash* (make-
81c0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 hash-table)).
81d0: 20 20 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e (run:test run
81e0: 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 -id run-info key
81f0: 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 vals runname tes
8200: 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 23 t-record flags #
8210: 66 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 f test-registry
8220: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
8230: 72 79 29 0a 20 20 20 20 20 20 28 68 61 73 68 2d ry). (hash-
8240: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
8250: 72 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d registry (runs:m
8260: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
8270: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
8280: 6d 2d 70 61 74 68 29 20 27 72 75 6e 6e 69 6e 67 m-path) 'running
8290: 29 0a 20 20 20 20 20 20 28 72 75 6e 73 3a 73 68 ). (runs:sh
82a0: 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 rink-can-run-mor
82b0: 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 20 e-tests-count)
82c0: 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 ;; DELAY TWEAKER
82d0: 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 (still needed?)
82e0: 0a 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 61 . ;; (threa
82f0: 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c d-sleep! *global
8300: 2d 64 65 6c 74 61 2a 29 0a 20 20 20 20 20 20 28 -delta*). (
8310: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
8320: 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 l? tal))(not (nu
8330: 6c 6c 3f 20 72 65 67 29 29 29 0a 09 20 20 28 6c ll? reg))).. (l
8340: 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ist (runs:queue-
8350: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg
8360: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
8370: 0a 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ...(runs:queue-n
8380: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
8390: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
83a0: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
83b0: 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 xt-reg tal reg r
83c0: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
83d0: 09 72 65 72 75 6e 73 29 0a 09 20 20 23 66 29 29 .reruns).. #f))
83e0: 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 6d . . ;; m
83f0: 75 73 74 20 62 65 20 77 65 20 68 61 76 65 20 75 ust be we have u
8400: 6e 6d 65 74 20 70 72 65 72 65 71 75 69 73 69 74 nmet prerequisit
8410: 65 73 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 es. ;;.
8420: 28 65 6c 73 65 0a 20 20 20 20 20 20 28 64 65 62 (else. (deb
8430: 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 4c ug:print 4 "FAIL
8440: 53 3a 20 22 20 66 61 69 6c 73 29 0a 20 20 20 20 S: " fails).
8450: 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d ;; If one or m
8460: 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 65 ore of the prere
8470: 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 qs-not-met are F
8480: 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e 20 AIL then we can
8490: 69 73 73 75 65 0a 20 20 20 20 20 20 3b 3b 20 61 issue. ;; a
84a0: 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 6f message and dro
84b0: 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 69 p hed from the i
84c0: 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 65 tems to be proce
84d0: 73 73 65 64 2e 0a 20 20 20 20 20 20 3b 3b 20 28 ssed.. ;; (
84e0: 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 2d runs:mixed-list-
84f0: 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 73 testname-and-tes
8500: 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 74 trec->list-of-st
8510: 72 69 6e 67 73 20 70 72 65 72 65 71 73 2d 6e 6f rings prereqs-no
8520: 74 2d 6d 65 74 29 0a 20 20 20 20 20 20 28 69 66 t-met). (if
8530: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 70 72 65 (not (null? pre
8540: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 reqs-not-met))..
8550: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
8560: 6e 66 6f 20 31 20 22 77 61 69 74 69 6e 67 20 6f nfo 1 "waiting o
8570: 6e 20 74 65 73 74 73 3b 20 22 20 28 73 74 72 69 n tests; " (stri
8580: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
8590: 09 09 09 09 09 09 20 20 20 20 28 72 75 6e 73 3a ...... (runs:
85a0: 6d 69 78 65 64 2d 6c 69 73 74 2d 74 65 73 74 6e mixed-list-testn
85b0: 61 6d 65 2d 61 6e 64 2d 74 65 73 74 72 65 63 2d ame-and-testrec-
85c0: 3e 6c 69 73 74 2d 6f 66 2d 73 74 72 69 6e 67 73 >list-of-strings
85d0: 20 0a 09 09 09 09 09 09 20 20 20 20 20 70 72 65 ....... pre
85e0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c reqs-not-met) ",
85f0: 20 22 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 "))). .
8600: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 (if (null? fa
8610: 69 6c 73 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 ils).. (begin..
8620: 20 20 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 ;; couldn't
8630: 72 75 6e 2c 20 74 61 6b 65 20 61 20 62 72 65 61 run, take a brea
8640: 74 68 65 72 0a 09 20 20 20 20 28 64 65 62 75 67 ther.. (debug
8650: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 :print-info 0 "W
8660: 61 69 74 69 6e 67 20 66 6f 72 20 6d 6f 72 65 20 aiting for more
8670: 77 6f 72 6b 20 74 6f 20 64 6f 2e 2e 2e 22 29 0a work to do...").
8680: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 . (thread-sle
8690: 65 70 21 20 31 29 0a 09 20 20 20 20 28 6c 69 73 ep! 1).. (lis
86a0: 74 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 t (car newtal)(c
86b0: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 dr newtal) reg r
86c0: 65 72 75 6e 73 29 29 0a 09 20 20 3b 3b 20 74 68 eruns)).. ;; th
86d0: 65 20 77 61 69 74 6f 6e 20 69 73 20 46 41 49 4c e waiton is FAIL
86e0: 20 73 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 so no point in
86f0: 74 72 79 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 trying to run he
8700: 64 20 65 76 65 72 20 61 67 61 69 6e 0a 09 20 20 d ever again..
8710: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 (if (or (not (nu
8720: 6c 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e ll? reg))(not (n
8730: 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 ull? tal)))..
8740: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
8750: 68 65 64 29 0a 09 09 20 20 28 62 65 67 69 6e 20 hed)... (begin
8760: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
8770: 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 44 72 6f int 1 "WARN: Dro
8780: 70 70 69 6e 67 20 74 65 73 74 20 22 20 28 64 62 pping test " (db
8790: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
87a0: 6d 65 20 68 65 64 29 20 22 2f 22 20 28 64 62 3a me hed) "/" (db:
87b0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
87c0: 74 68 20 68 65 64 29 0a 09 09 09 09 20 22 20 66 th hed)..... " f
87d0: 72 6f 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 6c rom the launch l
87e0: 69 73 74 20 61 73 20 69 74 20 68 61 73 20 70 72 ist as it has pr
87f0: 65 72 65 71 75 69 73 74 65 73 20 74 68 61 74 20 erequistes that
8800: 61 72 65 20 46 41 49 4c 22 29 0a 09 09 20 20 20 are FAIL")...
8810: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
8820: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
8830: 2d 63 6f 75 6e 74 29 20 3b 3b 20 44 45 4c 41 59 -count) ;; DELAY
8840: 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 TWEAKER (still
8850: 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 20 20 3b needed?)... ;
8860: 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ; (thread-sleep!
8870: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
8880: 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
8890: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
88a0: 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 istry (runs:make
88b0: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name
88c0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
88d0: 61 74 68 29 20 27 72 65 6d 6f 76 65 64 29 0a 09 ath) 'removed)..
88e0: 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 . (list (runs
88f0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
8900: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
8910: 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 72 75 egfull).... (ru
8920: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 ns:queue-next-ta
8930: 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e l tal reg reglen
8940: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 28 regfull).... (
8950: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
8960: 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 6c reg tal reg regl
8970: 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 en regfull)....
8980: 20 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e (cons hed rerun
8990: 73 29 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a s)))... (begin.
89a0: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
89b0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 nt 0 "WARNING: T
89c0: 65 73 74 20 6e 6f 74 20 70 72 6f 63 65 73 73 65 est not processe
89d0: 64 20 63 6f 72 72 65 63 74 6c 79 2e 20 43 6f 75 d correctly. Cou
89e0: 6c 64 20 62 65 20 61 20 72 61 63 65 20 63 6f 6e ld be a race con
89f0: 64 69 74 69 6f 6e 20 69 6e 20 79 6f 75 72 20 74 dition in your t
8a00: 65 73 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 est implementati
8a10: 6f 6e 3f 20 44 72 6f 70 70 69 6e 67 20 74 65 73 on? Dropping tes
8a20: 74 20 22 20 68 65 64 29 20 3b 3b 20 20 22 20 61 t " hed) ;; " a
8a30: 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 s it has prerequ
8a40: 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 istes that are F
8a50: 41 49 4c 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 AIL. (NOTE: hed
8a60: 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 is not a vector)
8a70: 22 29 0a 09 09 20 20 20 20 28 72 75 6e 73 3a 73 ")... (runs:s
8a80: 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f hrink-can-run-mo
8a90: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 20 re-tests-count)
8aa0: 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 ;; DELAY TWEAKER
8ab0: 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 (still needed?)
8ac0: 0a 09 09 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 ... ;; (list
8ad0: 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 hed tal reg reru
8ae0: 6e 73 29 0a 09 09 20 20 20 20 28 6c 69 73 74 20 ns)... (list
8af0: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
8b00: 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 newtal) reg rer
8b10: 75 6e 73 29 0a 09 09 20 20 20 20 29 29 29 29 29 uns)... )))))
8b20: 29 29 29 0a 0a 3b 3b 20 65 76 65 72 79 20 74 69 )))..;; every ti
8b30: 6d 65 20 74 68 6f 75 67 68 20 74 68 65 20 6c 6f me though the lo
8b40: 6f 70 20 69 6e 63 72 65 6d 65 6e 74 20 74 68 65 op increment the
8b50: 20 74 65 73 74 2f 69 74 65 6d 70 61 74 74 20 76 test/itempatt v
8b60: 61 6c 2e 0a 3b 3b 20 77 68 65 6e 20 74 68 65 20 al..;; when the
8b70: 6d 69 6e 20 69 73 20 3e 20 6d 61 78 2d 61 6c 6c min is > max-all
8b80: 6f 77 65 64 20 61 6e 64 20 6e 6f 6e 65 20 72 75 owed and none ru
8b90: 6e 6e 69 6e 67 20 74 68 65 6e 20 66 6f 72 63 65 nning then force
8ba0: 20 65 78 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 exit.;;.(define
8bb0: 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 *max-tries-hash
8bc0: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
8bd0: 6c 65 29 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 le))..;; test-re
8be0: 63 6f 72 64 73 20 69 73 20 61 20 68 61 73 68 20 cords is a hash
8bf0: 74 61 62 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 table testname:i
8c00: 74 65 6d 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 tem_path => vect
8c10: 6f 72 20 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 or < testname te
8c20: 73 74 63 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 stconfig waitons
8c30: 20 70 72 69 6f 72 69 74 79 20 69 74 65 6d 73 2d priority items-
8c40: 69 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 info ... >.(defi
8c50: 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 ne (runs:run-tes
8c60: 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 ts-queue run-id
8c70: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 runname test-rec
8c80: 6f 72 64 73 20 6b 65 79 76 61 6c 73 20 66 6c 61 ords keyvals fla
8c90: 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 gs test-patts re
8ca0: 71 75 69 72 65 64 2d 74 65 73 74 73 20 72 65 67 quired-tests reg
8cb0: 6c 65 6e 2d 69 6e 20 61 6c 6c 2d 74 65 73 74 73 len-in all-tests
8cc0: 2d 72 65 67 69 73 74 72 79 29 0a 20 20 3b 3b 20 -registry). ;;
8cd0: 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 74 68 At this point th
8ce0: 65 20 6c 69 73 74 20 6f 66 20 70 61 72 65 6e 74 e list of parent
8cf0: 20 74 65 73 74 73 20 69 73 20 65 78 70 61 6e 64 tests is expand
8d00: 65 64 20 0a 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 ed . ;; NB// Sh
8d10: 6f 75 6c 64 20 65 78 70 61 6e 64 20 69 74 65 6d ould expand item
8d20: 73 20 68 65 72 65 20 61 6e 64 20 74 68 65 6e 20 s here and then
8d30: 69 6e 73 65 72 74 20 69 6e 74 6f 20 74 68 65 20 insert into the
8d40: 72 75 6e 20 71 75 65 75 65 2e 0a 20 20 28 64 65 run queue.. (de
8d50: 62 75 67 3a 70 72 69 6e 74 20 35 20 22 74 65 73 bug:print 5 "tes
8d60: 74 2d 72 65 63 6f 72 64 73 3a 20 22 20 74 65 73 t-records: " tes
8d70: 74 2d 72 65 63 6f 72 64 73 20 22 2c 20 66 6c 61 t-records ", fla
8d80: 67 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c gs: " (hash-tabl
8d90: 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 29 e->alist flags))
8da0: 0a 0a 20 20 3b 3b 20 44 6f 20 6d 61 72 6b 2d 61 .. ;; Do mark-a
8db0: 6e 64 2d 66 69 6e 64 20 63 6c 65 61 6e 20 75 70 nd-find clean up
8dc0: 20 6f 66 20 64 62 20 62 65 66 6f 72 65 20 73 74 of db before st
8dd0: 61 72 74 69 6e 67 20 72 75 6e 69 6e 67 20 6f 66 arting runing of
8de0: 20 71 75 75 65 0a 20 20 3b 3b 0a 20 20 3b 3b 20 quue. ;;. ;;
8df0: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
8e00: 64 62 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b db:find-and-mark
8e10: 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 23 66 29 0a -incomplete #f).
8e20: 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 6e . (let ((run-in
8e30: 66 6f 20 20 20 20 20 20 20 20 20 20 20 20 20 20 fo
8e40: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
8e50: 64 62 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 db:get-run-info
8e60: 23 66 20 72 75 6e 2d 69 64 29 29 0a 09 28 74 65 #f run-id))..(te
8e70: 73 74 73 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 sts-info
8e80: 20 20 20 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 (mt:get-test
8e90: 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 s-for-run run-id
8ea0: 20 23 66 20 27 28 29 20 27 28 29 29 29 20 3b 3b #f '() '())) ;;
8eb0: 20 20 71 72 79 76 61 6c 73 3a 20 22 69 64 2c 74 qryvals: "id,t
8ec0: 65 73 74 6e 61 6d 65 2c 69 74 65 6d 5f 70 61 74 estname,item_pat
8ed0: 68 22 29 29 0a 09 28 73 6f 72 74 65 64 2d 74 65 h"))..(sorted-te
8ee0: 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 28 74 65 st-names (te
8ef0: 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f sts:sort-by-prio
8f00: 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 rity-and-waiton
8f10: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
8f20: 28 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 20 (test-registry
8f30: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
8f40: 68 2d 74 61 62 6c 65 29 29 0a 09 28 72 65 67 69 h-table))..(regi
8f50: 73 74 72 79 2d 6d 75 74 65 78 20 20 20 20 20 20 stry-mutex
8f60: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
8f70: 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 20 20 20 .(num-retries
8f80: 20 20 20 20 20 20 20 20 30 29 0a 09 28 6d 61 78 0)..(max
8f90: 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 20 20 -retries
8fa0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
8fb0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
8fc0: 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 69 65 etup" "maxretrie
8fd0: 73 22 29 29 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 s"))..(max-concu
8fe0: 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 28 6c 65 rrent-jobs (le
8ff0: 74 20 28 28 6d 63 6a 20 28 63 6f 6e 66 69 67 2d t ((mcj (config-
9000: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
9010: 74 2a 20 22 73 65 74 75 70 22 20 20 20 20 20 22 t* "setup" "
9020: 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a max_concurrent_j
9030: 6f 62 73 22 29 29 29 0a 09 09 09 09 20 28 69 66 obs")))..... (if
9040: 20 28 61 6e 64 20 6d 63 6a 20 28 73 74 72 69 6e (and mcj (strin
9050: 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 29 0a g->number mcj)).
9060: 09 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 .... (string
9070: 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 0a 09 09 ->number mcj)...
9080: 09 09 20 20 20 20 20 31 29 29 29 20 3b 3b 20 6c .. 1))) ;; l
9090: 65 6e 67 74 68 20 6f 66 20 74 68 65 20 72 65 67 ength of the reg
90a0: 69 73 74 65 72 20 71 75 65 75 65 20 61 68 65 61 ister queue ahea
90b0: 64 0a 09 28 72 65 67 6c 65 6e 20 20 20 20 20 20 d..(reglen
90c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
90d0: 75 6d 62 65 72 3f 20 72 65 67 6c 65 6e 2d 69 6e umber? reglen-in
90e0: 29 20 72 65 67 6c 65 6e 2d 69 6e 20 31 29 29 0a ) reglen-in 1)).
90f0: 09 28 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f .(last-time-inco
9100: 6d 70 6c 65 74 65 20 20 28 63 75 72 72 65 6e 74 mplete (current
9110: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 28 6c 61 73 -seconds))..(las
9120: 74 2d 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e t-time-some-runn
9130: 69 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ing (current-sec
9140: 6f 6e 64 73 29 29 29 0a 0a 20 20 20 20 3b 3b 20 onds))).. ;;
9150: 49 6e 69 74 69 61 6c 69 7a 65 20 74 68 65 20 74 Initialize the t
9160: 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 68 61 est-registery ha
9170: 73 68 20 77 69 74 68 20 74 65 73 74 73 20 74 68 sh with tests th
9180: 61 74 20 61 6c 72 65 61 64 79 20 68 61 76 65 20 at already have
9190: 61 20 72 65 63 6f 72 64 0a 20 20 20 20 3b 3b 20 a record. ;;
91a0: 63 6f 6e 76 65 72 74 20 73 74 61 74 65 20 74 6f convert state to
91b0: 20 73 79 6d 62 6f 6c 20 61 6e 64 20 75 73 65 20 symbol and use
91c0: 74 68 61 74 20 61 73 20 74 68 65 20 68 61 73 68 that as the hash
91d0: 20 76 61 6c 75 65 0a 20 20 20 20 28 66 6f 72 2d value. (for-
91e0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 72 each (lambda (tr
91f0: 65 63 29 0a 09 09 28 6c 65 74 20 28 28 69 64 20 ec)...(let ((id
9200: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
9210: 20 20 20 20 20 20 20 74 72 65 63 29 29 0a 09 09 trec))...
9220: 20 20 20 20 20 20 28 74 6e 20 28 64 62 3a 74 65 (tn (db:te
9230: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
9240: 20 74 72 65 63 29 29 0a 09 09 20 20 20 20 20 20 trec))...
9250: 28 69 70 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (ip (db:test-get
9260: 2d 69 74 65 6d 2d 70 61 74 68 20 74 72 65 63 29 -item-path trec)
9270: 29 0a 09 09 20 20 20 20 20 20 28 73 74 20 28 64 )... (st (d
9280: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
9290: 20 20 20 20 20 74 72 65 63 29 29 29 0a 09 09 20 trec)))...
92a0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
92b0: 3f 20 73 74 20 22 44 45 4c 45 54 45 44 22 29 29 ? st "DELETED"))
92c0: 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 ... (hash-t
92d0: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
92e0: 65 67 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 egistry (runs:ma
92f0: 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d ke-full-test-nam
9300: 65 20 74 6e 20 69 70 29 20 28 73 74 72 69 6e 67 e tn ip) (string
9310: 2d 3e 73 79 6d 62 6f 6c 20 73 74 29 29 29 29 29 ->symbol st)))))
9320: 0a 09 20 20 20 20 20 20 74 65 73 74 73 2d 69 6e .. tests-in
9330: 66 6f 29 0a 20 20 20 20 28 73 65 74 21 20 6d 61 fo). (set! ma
9340: 78 2d 72 65 74 72 69 65 73 20 28 69 66 20 28 61 x-retries (if (a
9350: 6e 64 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 nd max-retries (
9360: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d string->number m
9370: 61 78 2d 72 65 74 72 69 65 73 29 29 28 73 74 72 ax-retries))(str
9380: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d ing->number max-
9390: 72 65 74 72 69 65 73 29 20 31 30 30 29 29 0a 0a retries) 100))..
93a0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
93b0: 68 65 64 20 20 20 20 20 20 20 20 20 28 63 61 72 hed (car
93c0: 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d sorted-test-nam
93d0: 65 73 29 29 0a 09 20 20 20 20 20 20 20 28 74 61 es)).. (ta
93e0: 6c 20 20 20 20 20 20 20 20 20 28 63 64 72 20 73 l (cdr s
93f0: 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 orted-test-names
9400: 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 67 20 )).. (reg
9410: 20 20 20 20 20 20 20 20 27 28 29 29 20 3b 3b 20 '()) ;;
9420: 72 65 67 69 73 74 65 72 65 64 2c 20 70 75 74 20 registered, put
9430: 74 68 65 73 65 20 61 74 20 74 68 65 20 68 65 61 these at the hea
9440: 64 20 6f 66 20 74 61 6c 20 0a 09 20 20 20 20 20 d of tal ..
9450: 20 20 28 72 65 72 75 6e 73 20 20 20 20 20 20 27 (reruns '
9460: 28 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 ())). (if (
9470: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e not (null? rerun
9480: 73 29 29 28 64 65 62 75 67 3a 70 72 69 6e 74 2d s))(debug:print-
9490: 69 6e 66 6f 20 34 20 22 72 65 72 75 6e 73 3d 22 info 4 "reruns="
94a0: 20 72 65 72 75 6e 73 29 29 0a 0a 20 20 20 20 20 reruns))..
94b0: 20 3b 3b 20 48 65 72 65 20 77 65 20 6d 61 72 6b ;; Here we mark
94c0: 20 61 6e 79 20 6f 6c 64 20 64 65 66 75 6e 63 74 any old defunct
94d0: 20 74 65 73 74 73 20 61 73 20 69 6e 63 6f 6d 70 tests as incomp
94e0: 6c 65 74 65 2e 20 44 6f 20 74 68 69 73 20 65 76 lete. Do this ev
94f0: 65 72 79 20 66 69 66 74 65 65 6e 20 6d 69 6e 75 ery fifteen minu
9500: 74 65 73 0a 20 20 20 20 20 20 3b 3b 20 28 69 66 tes. ;; (if
9510: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
9520: 6f 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d onds)(+ last-tim
9530: 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 39 30 30 e-incomplete 900
9540: 29 29 0a 20 20 20 20 20 20 3b 3b 20 20 20 20 20 )). ;;
9550: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 3b 3b 20 (begin. ;;
9560: 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 (set! last
9570: 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 -time-incomplete
9580: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
9590: 73 29 29 0a 20 20 20 20 20 20 3b 3b 20 20 20 20 s)). ;;
95a0: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
95b0: 75 6e 20 64 62 3a 66 69 6e 64 2d 61 6e 64 2d 6d un db:find-and-m
95c0: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 23 ark-incomplete #
95d0: 66 29 29 29 0a 0a 20 20 20 20 20 20 3b 3b 20 28 f))).. ;; (
95e0: 70 72 69 6e 74 20 22 54 6f 70 20 6f 66 20 6c 6f print "Top of lo
95f0: 6f 70 2c 20 68 65 64 3d 22 20 68 65 64 20 22 2c op, hed=" hed ",
9600: 20 74 61 6c 3d 22 20 74 61 6c 20 22 20 2c 72 65 tal=" tal " ,re
9610: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 0a 20 runs=" reruns).
9620: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
9630: 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 t-record (hash-t
9640: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
9650: 63 6f 72 64 73 20 68 65 64 29 29 0a 09 20 20 20 cords hed))..
9660: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 (test-name (
9670: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
9680: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
9690: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
96a0: 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 28 74 (tconfig (t
96b0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
96c0: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 et-testconfig te
96d0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
96e0: 20 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 28 (jobgroup (
96f0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 config-lookup tc
9700: 6f 6e 66 69 67 20 22 74 65 73 74 5f 6d 65 74 61 onfig "test_meta
9710: 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 " "jobgroup"))..
9720: 20 20 20 20 20 28 74 65 73 74 6d 6f 64 65 20 20 (testmode
9730: 20 20 28 6c 65 74 20 28 28 6d 20 28 63 6f 6e 66 (let ((m (conf
9740: 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 ig-lookup tconfi
9750: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
9760: 20 22 6d 6f 64 65 22 29 29 29 0a 09 09 09 20 20 "mode")))....
9770: 20 20 28 69 66 20 6d 20 28 6d 61 70 20 73 74 72 (if m (map str
9780: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 ing->symbol (str
9790: 69 6e 67 2d 73 70 6c 69 74 20 6d 29 29 20 27 28 ing-split m)) '(
97a0: 6e 6f 72 6d 61 6c 29 29 29 29 0a 09 20 20 20 20 normal))))..
97b0: 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 74 (waitons (t
97c0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
97d0: 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 et-waitons te
97e0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
97f0: 20 20 28 70 72 69 6f 72 69 74 79 20 20 20 20 28 (priority (
9800: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
9810: 67 65 74 2d 70 72 69 6f 72 69 74 79 20 20 20 74 get-priority t
9820: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 est-record))..
9830: 20 20 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 (itemdat
9840: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
9850: 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 -get-itemdat
9860: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b test-record)) ;;
9870: 20 69 74 65 6d 64 61 74 20 63 61 6e 20 62 65 20 itemdat can be
9880: 61 20 73 74 72 69 6e 67 2c 20 6c 69 73 74 20 6f a string, list o
9890: 72 20 23 66 0a 09 20 20 20 20 20 28 69 74 65 6d r #f.. (item
98a0: 73 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 s (tests:t
98b0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
98c0: 6d 73 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 ms test-rec
98d0: 6f 72 64 29 29 0a 09 20 20 20 20 20 28 69 74 65 ord)).. (ite
98e0: 6d 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d 6c m-path (item-l
98f0: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
9900: 74 29 29 0a 09 20 20 20 20 20 28 74 66 75 6c 6c t)).. (tfull
9910: 6e 61 6d 65 20 20 20 28 72 75 6e 73 3a 6d 61 6b name (runs:mak
9920: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
9930: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
9940: 70 61 74 68 29 29 0a 09 20 20 20 20 20 28 6e 65 path)).. (ne
9950: 77 74 61 6c 20 20 20 20 20 20 28 61 70 70 65 6e wtal (appen
9960: 64 20 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 d tal (list hed)
9970: 29 29 0a 09 20 20 20 20 20 28 72 65 67 66 75 6c )).. (regful
9980: 6c 20 20 20 20 20 28 3e 3d 20 28 6c 65 6e 67 74 l (>= (lengt
9990: 68 20 72 65 67 29 20 72 65 67 6c 65 6e 29 29 0a h reg) reglen)).
99a0: 09 20 20 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 . (num-runni
99b0: 6e 67 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 ng (cdb:remote-r
99c0: 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d un db:get-count-
99d0: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f tests-running-fo
99e0: 72 2d 72 75 6e 2d 69 64 20 23 66 20 72 75 6e 2d r-run-id #f run-
99f0: 69 64 29 29 29 0a 0a 20 20 20 20 20 20 28 69 66 id))).. (if
9a00: 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 (> num-running
9a10: 30 29 0a 09 20 20 28 73 65 74 21 20 6c 61 73 74 0).. (set! last
9a20: 2d 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 -time-some-runni
9a30: 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ng (current-seco
9a40: 6e 64 73 29 29 29 0a 0a 20 20 20 20 20 20 28 69 nds))).. (i
9a50: 66 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 f (> (current-se
9a60: 63 6f 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 conds)(+ last-ti
9a70: 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 6e 67 20 me-some-running
9a80: 36 30 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 60)).. (hash-ta
9a90: 62 6c 65 2d 73 65 74 21 20 2a 6d 61 78 2d 74 72 ble-set! *max-tr
9aa0: 69 65 73 2d 68 61 73 68 2a 20 74 66 75 6c 6c 6e ies-hash* tfulln
9ab0: 61 6d 65 20 28 2b 20 28 68 61 73 68 2d 74 61 62 ame (+ (hash-tab
9ac0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
9ad0: 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 max-tries-hash*
9ae0: 74 66 75 6c 6c 6e 61 6d 65 20 30 29 20 31 29 29 tfullname 0) 1))
9af0: 29 0a 09 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 )..;; (debug:pri
9b00: 6e 74 20 30 20 22 6d 61 78 2d 74 72 69 65 73 2d nt 0 "max-tries-
9b10: 68 61 73 68 3a 20 22 20 28 68 61 73 68 2d 74 61 hash: " (hash-ta
9b20: 62 6c 65 2d 3e 61 6c 69 73 74 20 2a 6d 61 78 2d ble->alist *max-
9b30: 74 72 69 65 73 2d 68 61 73 68 2a 29 29 0a 0a 09 tries-hash*))...
9b40: 3b 3b 20 45 6e 73 75 72 65 20 61 6c 6c 20 74 6f ;; Ensure all to
9b50: 70 20 6c 65 76 65 6c 20 74 65 73 74 73 20 67 65 p level tests ge
9b60: 74 20 72 65 67 69 73 74 65 72 65 64 2e 20 54 68 t registered. Th
9b70: 69 73 20 77 61 79 20 74 68 65 79 20 73 68 6f 77 is way they show
9b80: 20 75 70 20 61 73 20 22 4e 4f 54 5f 53 54 41 52 up as "NOT_STAR
9b90: 54 45 44 22 20 6f 6e 20 74 68 65 20 64 61 73 68 TED" on the dash
9ba0: 62 6f 61 72 64 0a 09 3b 3b 20 61 6e 64 20 69 74 board..;; and it
9bb0: 20 69 73 20 63 6c 65 61 72 20 74 68 65 79 20 2a is clear they *
9bc0: 73 68 6f 75 6c 64 2a 20 68 61 76 65 20 72 75 6e should* have run
9bd0: 20 62 75 74 20 64 69 64 20 6e 6f 74 2e 0a 09 28 but did not...(
9be0: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
9bf0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
9c00: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
9c10: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
9c20: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
9c30: 65 20 22 22 29 20 23 66 29 29 0a 09 20 20 20 20 e "") #f))..
9c40: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 63 (begin.. (c
9c50: 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 db:tests-registe
9c60: 72 2d 74 65 73 74 20 2a 72 75 6e 72 65 6d 6f 74 r-test *runremot
9c70: 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e e* run-id test-n
9c80: 61 6d 65 20 22 22 29 0a 09 20 20 20 20 20 20 28 ame "").. (
9c90: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9ca0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 72 test-registry (r
9cb0: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
9cc0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
9cd0: 65 20 22 22 29 20 27 64 6f 6e 65 29 29 29 0a 09 e "") 'done)))..
9ce0: 0a 09 3b 3b 20 46 61 73 74 20 73 6b 69 70 20 6f ..;; Fast skip o
9cf0: 66 20 74 65 73 74 73 20 74 68 61 74 20 61 72 65 f tests that are
9d00: 20 61 6c 72 65 61 64 79 20 22 43 4f 4d 50 4c 45 already "COMPLE
9d10: 54 45 44 22 20 2d 20 4e 4f 21 20 43 61 6e 6e 6f TED" - NO! Canno
9d20: 74 20 64 6f 20 74 68 61 74 20 61 73 20 74 68 65 t do that as the
9d30: 20 69 74 65 6d 73 20 6d 61 79 20 6e 6f 74 20 68 items may not h
9d40: 61 76 65 20 62 65 65 6e 20 65 78 70 61 6e 64 65 ave been expande
9d50: 64 20 79 65 74 20 3a 28 0a 09 3b 3b 0a 09 28 69 d yet :(..;;..(i
9d60: 66 20 28 6d 65 6d 62 65 72 20 28 68 61 73 68 2d f (member (hash-
9d70: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
9d80: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
9d90: 74 66 75 6c 6c 6e 61 6d 65 20 23 66 29 20 0a 09 tfullname #f) ..
9da0: 09 20 20 20 20 27 28 44 4f 4e 4f 54 52 55 4e 20 . '(DONOTRUN
9db0: 72 65 6d 6f 76 65 64 29 29 20 3b 3b 20 2a 63 6f removed)) ;; *co
9dc0: 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 mmon:cant-run-st
9dd0: 61 74 65 73 2d 73 79 6d 2a 29 20 3b 3b 20 27 28 ates-sym*) ;; '(
9de0: 43 4f 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 COMPLETED KILLED
9df0: 20 57 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 WAIVED UNKNOWN
9e00: 49 4e 43 4f 4d 50 4c 45 54 45 29 29 0a 09 20 20 INCOMPLETE))..
9e10: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
9e20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
9e30: 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 74 65 o 0 "Skipping te
9e40: 73 74 20 22 20 74 66 75 6c 6c 6e 61 6d 65 20 22 st " tfullname "
9e50: 20 61 73 20 69 74 20 68 61 73 20 62 65 65 6e 20 as it has been
9e60: 6d 61 72 6b 65 64 20 64 6f 20 6e 6f 74 20 72 75 marked do not ru
9e70: 6e 20 64 75 65 20 74 6f 20 62 65 69 6e 67 20 63 n due to being c
9e80: 6f 6d 70 6c 65 74 65 64 20 6f 72 20 6e 6f 74 20 ompleted or not
9e90: 72 75 6e 6e 61 62 6c 65 22 29 0a 09 20 20 20 20 runnable")..
9ea0: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
9eb0: 6e 75 6c 6c 3f 20 74 61 6c 29 29 28 6e 6f 74 20 null? tal))(not
9ec0: 28 6e 75 6c 6c 3f 20 72 65 67 29 29 29 0a 09 09 (null? reg)))...
9ed0: 20 20 28 6c 6f 6f 70 20 28 72 75 6e 73 3a 71 75 (loop (runs:qu
9ee0: 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c eue-next-hed tal
9ef0: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
9f00: 75 6c 6c 29 0a 09 09 09 28 72 75 6e 73 3a 71 75 ull)....(runs:qu
9f10: 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c eue-next-tal tal
9f20: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
9f30: 75 6c 6c 29 0a 09 09 09 28 72 75 6e 73 3a 71 75 ull)....(runs:qu
9f40: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c eue-next-reg tal
9f50: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
9f60: 75 6c 6c 29 0a 09 09 09 72 65 72 75 6e 73 29 29 ull)....reruns))
9f70: 29 29 0a 09 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 ))... ;; (loop
9f80: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
9f90: 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 29 l) reg reruns)))
9fa0: 29 0a 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
9fb0: 20 34 20 22 54 4f 50 20 4f 46 20 4c 4f 4f 50 20 4 "TOP OF LOOP
9fc0: 3d 3e 20 22 0a 09 09 20 20 20 20 20 22 74 65 73 => "... "tes
9fd0: 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e t-name: " test-n
9fe0: 61 6d 65 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 ame... "\n
9ff0: 74 65 73 74 2d 72 65 63 6f 72 64 20 20 22 20 74 test-record " t
a000: 65 73 74 2d 72 65 63 6f 72 64 0a 09 09 20 20 20 est-record...
a010: 20 20 22 5c 6e 20 20 68 65 64 3a 20 20 20 20 20 "\n hed:
a020: 20 20 20 20 22 20 68 65 64 0a 09 09 20 20 20 20 " hed...
a030: 20 22 5c 6e 20 20 69 74 65 6d 64 61 74 3a 20 20 "\n itemdat:
a040: 20 20 20 22 20 69 74 65 6d 64 61 74 0a 09 09 20 " itemdat...
a050: 20 20 20 20 22 5c 6e 20 20 69 74 65 6d 73 3a 20 "\n items:
a060: 20 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 " items...
a070: 20 20 20 20 20 22 5c 6e 20 20 69 74 65 6d 2d 70 "\n item-p
a080: 61 74 68 3a 20 20 20 22 20 69 74 65 6d 2d 70 61 ath: " item-pa
a090: 74 68 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 77 th... "\n w
a0a0: 61 69 74 6f 6e 73 3a 20 20 20 20 20 22 20 77 61 aitons: " wa
a0b0: 69 74 6f 6e 73 0a 09 09 20 20 20 20 20 22 5c 6e itons... "\n
a0c0: 20 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 22 num-retries: "
a0d0: 20 6e 75 6d 2d 72 65 74 72 69 65 73 0a 09 09 20 num-retries...
a0e0: 20 20 20 20 22 5c 6e 20 20 74 61 6c 3a 20 20 20 "\n tal:
a0f0: 20 20 20 20 20 20 22 20 74 61 6c 0a 09 09 20 20 " tal...
a100: 20 20 20 22 5c 6e 20 20 72 65 72 75 6e 73 3a 20 "\n reruns:
a110: 20 20 20 20 20 22 20 72 65 72 75 6e 73 0a 09 09 " reruns...
a120: 20 20 20 20 20 22 5c 6e 20 20 72 65 67 66 75 6c "\n regful
a130: 6c 3a 20 20 20 20 20 22 20 72 65 67 66 75 6c 6c l: " regfull
a140: 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 72 65 67 ... "\n reg
a150: 6c 65 6e 3a 20 20 20 20 20 20 22 20 72 65 67 6c len: " regl
a160: 65 6e 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 6c en... "\n l
a170: 65 6e 67 74 68 20 72 65 67 3a 20 20 22 20 28 6c ength reg: " (l
a180: 65 6e 67 74 68 20 72 65 67 29 0a 09 09 20 20 20 ength reg)...
a190: 20 20 22 5c 6e 20 20 72 65 67 3a 20 20 20 20 20 "\n reg:
a1a0: 20 20 20 20 22 20 72 65 67 29 0a 0a 09 3b 3b 20 " reg)...;;
a1b0: 63 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e check for hed in
a1c0: 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 waitons => this
a1d0: 20 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c would be circul
a1e0: 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e ar, remove it an
a1f0: 64 20 69 73 73 75 65 20 61 6e 0a 09 3b 3b 20 65 d issue an..;; e
a200: 72 72 6f 72 0a 09 28 69 66 20 28 6d 65 6d 62 65 rror..(if (membe
a210: 72 20 74 65 73 74 2d 6e 61 6d 65 20 77 61 69 74 r test-name wait
a220: 6f 6e 73 29 0a 09 20 20 20 20 28 62 65 67 69 6e ons).. (begin
a230: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
a240: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 rint 0 "ERROR: t
a250: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
a260: 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 " has listed its
a270: 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c elf as a waiton,
a280: 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 please correct
a290: 74 68 69 73 21 22 29 0a 09 20 20 20 20 20 20 28 this!").. (
a2a0: 73 65 74 21 20 77 61 69 74 6f 6e 20 28 66 69 6c set! waiton (fil
a2b0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 ter (lambda (x)(
a2c0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 not (equal? x he
a2d0: 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 d))) waitons))))
a2e0: 0a 0a 09 28 63 6f 6e 64 20 0a 09 20 0a 09 20 3b ...(cond .. .. ;
a2f0: 3b 20 57 65 20 77 61 6e 74 20 74 6f 20 63 61 74 ; We want to cat
a300: 63 68 20 74 65 73 74 73 20 74 68 61 74 20 68 61 ch tests that ha
a310: 76 65 20 77 61 69 74 6f 6e 73 20 74 68 61 74 20 ve waitons that
a320: 61 72 65 20 4e 4f 54 20 69 6e 20 74 68 65 20 71 are NOT in the q
a330: 75 65 75 65 20 61 6e 64 20 64 69 73 63 61 72 64 ueue and discard
a340: 20 74 68 65 6d 20 49 46 46 20 0a 09 20 3b 3b 20 them IFF .. ;;
a350: 74 68 65 79 20 68 61 76 65 20 62 65 65 6e 20 74 they have been t
a360: 68 72 6f 75 67 68 20 74 68 65 20 77 72 69 6e 67 hrough the wring
a370: 65 72 20 31 30 20 6f 72 20 6d 6f 72 65 20 74 69 er 10 or more ti
a380: 6d 65 73 0a 09 20 28 28 61 6e 64 20 28 6c 69 73 mes.. ((and (lis
a390: 74 3f 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 t? waitons)..
a3a0: 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (not (null?
a3b0: 77 61 69 74 6f 6e 73 29 29 0a 09 20 20 20 20 20 waitons))..
a3c0: 20 20 28 3e 20 28 68 61 73 68 2d 74 61 62 6c 65 (> (hash-table
a3d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 6d 61 -ref/default *ma
a3e0: 78 2d 74 72 69 65 73 2d 68 61 73 68 2a 20 74 66 x-tries-hash* tf
a3f0: 75 6c 6c 6e 61 6d 65 20 30 29 20 31 30 29 0a 09 ullname 0) 10)..
a400: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c (not (nul
a410: 6c 3f 20 28 66 69 6c 74 65 72 0a 09 09 09 20 20 l? (filter....
a420: 20 20 6e 75 6d 62 65 72 3f 0a 09 09 09 20 20 20 number?....
a430: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 77 (map (lambda (w
a440: 61 69 74 6f 6e 29 0a 09 09 09 09 20 20 20 28 69 aiton)..... (i
a450: 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 6d 65 6d f (and (not (mem
a460: 62 65 72 20 77 61 69 74 6f 6e 20 74 61 6c 29 29 ber waiton tal))
a470: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
a480: 68 69 73 20 77 61 69 74 6f 6e 20 69 73 20 6e 6f his waiton is no
a490: 74 20 69 6e 20 74 68 65 20 6c 69 73 74 20 74 6f t in the list to
a4a0: 20 62 65 20 74 72 69 65 64 20 74 6f 20 72 75 6e be tried to run
a4b0: 0a 09 09 09 09 09 20 20 20 20 28 6e 6f 74 20 28 ...... (not (
a4c0: 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 72 65 member waiton re
a4d0: 72 75 6e 73 29 29 29 0a 09 09 09 09 20 20 20 20 runs))).....
a4e0: 20 20 20 31 0a 09 09 09 09 20 20 20 20 20 20 20 1.....
a4f0: 23 66 29 29 0a 09 09 09 09 20 77 61 69 74 6f 6e #f))..... waiton
a500: 73 29 29 29 29 29 20 3b 3b 20 63 6f 75 6c 64 20 s))))) ;; could
a510: 64 6f 20 74 68 69 73 20 6d 6f 72 65 20 65 6c 65 do this more ele
a520: 67 61 6e 74 6c 79 20 77 69 74 68 20 61 20 6d 61 gantly with a ma
a530: 72 6b 65 72 2e 2e 2e 2e 0a 09 20 20 28 64 65 62 rker...... (deb
a540: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
a550: 49 4e 47 3a 20 4d 61 72 6b 69 6e 67 20 74 65 73 ING: Marking tes
a560: 74 20 22 20 74 66 75 6c 6c 6e 61 6d 65 20 22 20 t " tfullname "
a570: 61 73 20 6e 6f 74 20 72 75 6e 6e 61 62 6c 65 2e as not runnable.
a580: 20 49 74 20 69 73 20 77 61 69 74 69 6e 67 20 6f It is waiting o
a590: 6e 20 74 65 73 74 73 20 74 68 61 74 20 63 61 6e n tests that can
a5a0: 6e 6f 74 20 62 65 20 72 75 6e 2e 20 47 69 76 69 not be run. Givi
a5b0: 6e 67 20 75 70 20 6e 6f 77 2e 22 29 0a 09 20 20 ng up now.")..
a5c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
a5d0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 test-registry t
a5e0: 66 75 6c 6c 6e 61 6d 65 20 27 72 65 6d 6f 76 65 fullname 'remove
a5f0: 64 29 29 0a 0a 09 20 3b 3b 20 69 74 65 6d 73 20 d))... ;; items
a600: 69 73 20 23 66 20 74 68 65 6e 20 74 68 65 20 74 is #f then the t
a610: 65 73 74 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 est is ok to be
a620: 68 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 handed off to la
a630: 75 6e 63 68 20 28 62 75 74 20 6e 6f 74 20 62 65 unch (but not be
a640: 66 6f 72 65 29 0a 09 20 3b 3b 20 0a 09 20 28 28 fore).. ;; .. ((
a650: 6e 6f 74 20 69 74 65 6d 73 29 0a 09 20 20 28 64 not items).. (d
a660: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
a670: 34 20 22 4f 55 54 45 52 20 43 4f 4e 44 3a 20 28 4 "OUTER COND: (
a680: 6e 6f 74 20 69 74 65 6d 73 29 22 29 0a 09 20 20 not items)")..
a690: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 74 (if (and (not (t
a6a0: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
a6b0: 70 61 74 74 73 20 28 74 65 73 74 73 3a 74 65 73 patts (tests:tes
a6c0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
a6d0: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 ame test-record)
a6e0: 20 69 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 item-path requi
a6f0: 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 red: required-te
a700: 73 74 73 29 29 0a 09 09 20 20 20 28 6e 6f 74 20 sts))... (not
a710: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 (null? tal)))..
a720: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
a730: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
a740: 67 20 72 65 72 75 6e 73 29 29 0a 09 20 20 28 6c g reruns)).. (l
a750: 65 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 20 28 et ((loop-list (
a760: 72 75 6e 73 3a 70 72 6f 63 65 73 73 2d 65 78 70 runs:process-exp
a770: 61 6e 64 65 64 2d 74 65 73 74 73 20 68 65 64 20 anded-tests hed
a780: 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 tal reg reruns r
a790: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 20 74 65 eglen regfull te
a7a0: 73 74 2d 72 65 63 6f 72 64 20 72 75 6e 6e 61 6d st-record runnam
a7b0: 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d e test-name item
a7c0: 2d 70 61 74 68 20 6a 6f 62 67 72 6f 75 70 20 6d -path jobgroup m
a7d0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
a7e0: 62 73 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e bs run-id waiton
a7f0: 73 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 s item-path test
a800: 6d 6f 64 65 20 74 65 73 74 2d 70 61 74 74 73 20 mode test-patts
a810: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 74 required-tests t
a820: 65 73 74 2d 72 65 67 69 73 74 72 79 20 72 65 67 est-registry reg
a830: 69 73 74 72 79 2d 6d 75 74 65 78 20 66 6c 61 67 istry-mutex flag
a840: 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 2d 69 6e s keyvals run-in
a850: 66 6f 20 6e 65 77 74 61 6c 20 61 6c 6c 2d 74 65 fo newtal all-te
a860: 73 74 73 2d 72 65 67 69 73 74 72 79 29 29 29 0a sts-registry))).
a870: 09 20 20 20 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 . (if loop-li
a880: 73 74 20 28 61 70 70 6c 79 20 6c 6f 6f 70 20 6c st (apply loop l
a890: 6f 6f 70 2d 6c 69 73 74 29 29 29 29 0a 0a 09 20 oop-list))))...
a8a0: 3b 3b 20 69 74 65 6d 73 20 70 72 6f 63 65 73 73 ;; items process
a8b0: 65 64 20 69 6e 74 6f 20 61 20 6c 69 73 74 20 62 ed into a list b
a8c0: 75 74 20 6e 6f 74 20 63 61 6d 65 20 69 6e 20 61 ut not came in a
a8d0: 73 20 61 20 6c 69 73 74 20 62 65 65 6e 20 70 72 s a list been pr
a8e0: 6f 63 65 73 73 65 64 0a 09 20 3b 3b 0a 09 20 28 ocessed.. ;;.. (
a8f0: 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d (and (list? item
a900: 73 29 20 20 20 20 20 3b 3b 20 74 68 75 73 20 77 s) ;; thus w
a910: 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 e know our items
a920: 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 61 6c are already cal
a930: 63 75 6c 61 74 65 64 0a 09 20 20 20 20 20 20 20 culated..
a940: 28 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 29 29 (not itemdat))
a950: 20 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 ;; and not yet
a960: 20 65 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 expanded into t
a970: 68 65 20 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 he list of thing
a980: 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 s to be done..
a990: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
a9a0: 6f 20 34 20 22 4f 55 54 45 52 20 43 4f 4e 44 3a o 4 "OUTER COND:
a9b0: 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 (and (list? ite
a9c0: 6d 73 29 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 ms)(not itemdat)
a9d0: 29 22 29 0a 09 20 20 3b 3b 20 4d 75 73 74 20 64 )").. ;; Must d
a9e0: 65 74 65 72 6d 69 6e 65 20 69 66 20 74 68 65 20 etermine if the
a9f0: 69 74 65 6d 73 20 6c 69 73 74 20 69 73 20 76 61 items list is va
aa00: 6c 69 64 2e 20 44 69 73 63 61 72 64 20 74 68 65 lid. Discard the
aa10: 20 74 65 73 74 20 69 66 20 69 74 20 69 73 20 6e test if it is n
aa20: 6f 74 2e 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ot... (if (and
aa30: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 0a 09 09 (list? items)...
aa40: 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 69 74 (> (length it
aa50: 65 6d 73 29 20 30 29 0a 09 09 20 20 20 28 61 6e ems) 0)... (an
aa60: 64 20 28 6c 69 73 74 3f 20 28 63 61 72 20 69 74 d (list? (car it
aa70: 65 6d 73 29 29 0a 09 09 09 28 3e 20 28 6c 65 6e ems))....(> (len
aa80: 67 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 gth (car items))
aa90: 20 30 29 29 0a 09 09 20 20 20 28 64 65 62 75 67 0))... (debug
aaa0: 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 0a :debug-mode 1)).
aab0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
aac0: 69 6e 74 20 32 20 28 6d 61 70 20 28 6c 61 6d 62 int 2 (map (lamb
aad0: 64 61 20 28 72 6f 77 29 0a 09 09 09 09 20 20 20 da (row).....
aae0: 20 28 63 6f 6e 63 20 28 73 74 72 69 6e 67 2d 69 (conc (string-i
aaf0: 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 09 09 ntersperse......
ab00: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
ab10: 28 76 61 72 76 61 6c 29 0a 09 09 09 09 09 09 20 (varval).......
ab20: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
ab30: 65 72 73 65 20 76 61 72 76 61 6c 20 22 3d 22 29 erse varval "=")
ab40: 29 0a 09 09 09 09 09 09 72 6f 77 29 0a 09 09 09 ).......row)....
ab50: 09 09 20 20 20 22 20 22 29 0a 09 09 09 09 09 20 .. " ")......
ab60: 20 22 5c 6e 22 29 29 0a 09 09 09 09 20 20 69 74 "\n"))..... it
ab70: 65 6d 73 29 29 29 0a 09 20 20 28 66 6f 72 2d 65 ems))).. (for-e
ab80: 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 ach.. (lambda
ab90: 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 20 20 (my-itemdat)..
aba0: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 (let* ((new-t
abb0: 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 est-record (let
abc0: 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 ((newrec (make-t
abd0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 29 29 ests:testqueue))
abe0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 76 65 )..... (ve
abf0: 63 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d ctor-copy! test-
ac00: 72 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 record newrec)..
ac10: 09 09 09 20 20 20 20 20 20 20 6e 65 77 72 65 63 ... newrec
ac20: 29 29 0a 09 09 20 20 20 20 28 6d 79 2d 69 74 65 ))... (my-ite
ac30: 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 m-path (item-lis
ac40: 74 2d 3e 70 61 74 68 20 6d 79 2d 69 74 65 6d 64 t->path my-itemd
ac50: 61 74 29 29 29 0a 09 20 20 20 20 20 20 20 28 69 at))).. (i
ac60: 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 f (tests:match t
ac70: 65 73 74 2d 70 61 74 74 73 20 68 65 64 20 6d 79 est-patts hed my
ac80: 2d 69 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 -item-path requi
ac90: 72 65 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 red: required-te
aca0: 73 74 73 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 sts) ;; (patt-li
acb0: 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d st-match my-item
acc0: 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 74 73 -path item-patts
acd0: 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 79 ) ;; y
ace0: 65 73 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 70 es, we want to p
acf0: 72 6f 63 65 73 73 20 74 68 69 73 20 69 74 65 6d rocess this item
ad00: 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e , NOTE: Should n
ad10: 6f 74 20 6e 65 65 64 20 74 68 69 73 20 63 68 65 ot need this che
ad20: 63 6b 20 68 65 72 65 21 0a 09 09 20 20 20 28 6c ck here!... (l
ad30: 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d 65 et ((newtestname
ad40: 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c (runs:make-full
ad50: 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 6d -test-name hed m
ad60: 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 20 y-item-path)))
ad70: 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 ;; test names
ad80: 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 are unique on te
ad90: 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 stname/item-path
ada0: 0a 09 09 20 20 20 20 20 28 74 65 73 74 73 3a 74 ... (tests:t
adb0: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
adc0: 6d 73 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 ms! new-test
add0: 2d 72 65 63 6f 72 64 20 23 66 29 0a 09 09 20 20 -record #f)...
ade0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
adf0: 65 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 eue-set-itemdat!
ae00: 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f new-test-reco
ae10: 72 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 rd my-itemdat)..
ae20: 09 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 . (tests:tes
ae30: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f tqueue-set-item_
ae40: 70 61 74 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 path! new-test-r
ae50: 65 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 ecord my-item-pa
ae60: 74 68 29 0a 09 09 20 20 20 20 20 28 68 61 73 68 th)... (hash
ae70: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
ae80: 2d 72 65 63 6f 72 64 73 20 6e 65 77 74 65 73 74 -records newtest
ae90: 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 72 65 name new-test-re
aea0: 63 6f 72 64 29 0a 09 09 20 20 20 20 20 28 73 65 cord)... (se
aeb0: 74 21 20 74 61 6c 20 28 61 70 70 65 6e 64 20 74 t! tal (append t
aec0: 61 6c 20 28 6c 69 73 74 20 6e 65 77 74 65 73 74 al (list newtest
aed0: 6e 61 6d 65 29 29 29 29 29 29 29 20 3b 3b 20 73 name))))))) ;; s
aee0: 69 6e 63 65 20 74 68 65 73 65 20 61 72 65 20 69 ince these are i
aef0: 74 65 6d 69 7a 65 64 20 63 72 65 61 74 65 20 6e temized create n
af00: 65 77 20 74 65 73 74 20 6e 61 6d 65 73 20 74 65 ew test names te
af10: 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a stname/itempath.
af20: 09 20 20 20 69 74 65 6d 73 29 0a 0a 09 20 20 3b . items)... ;
af30: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ; (debug:print-i
af40: 6e 66 6f 20 30 20 22 54 65 73 74 20 22 20 28 74 nfo 0 "Test " (t
af50: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
af60: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
af70: 2d 72 65 63 6f 72 64 29 20 22 20 69 73 20 69 74 -record) " is it
af80: 65 6d 69 7a 65 64 20 62 75 74 20 68 61 73 20 6e emized but has n
af90: 6f 20 69 74 65 6d 73 22 29 0a 0a 09 20 20 3b 3b o items")... ;;
afa0: 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 77 At this point w
afb0: 65 20 68 61 76 65 20 70 6f 73 73 69 62 6c 79 20 e have possibly
afc0: 61 64 64 65 64 20 69 74 65 6d 73 20 74 6f 20 74 added items to t
afd0: 61 6c 20 62 75 74 20 61 6c 6c 20 6d 75 73 74 20 al but all must
afe0: 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f be handed off to
aff0: 20 0a 09 20 20 3b 3b 20 49 4e 4e 45 52 20 43 4f .. ;; INNER CO
b000: 4e 44 20 6c 6f 67 69 63 2e 20 49 20 74 68 69 6e ND logic. I thin
b010: 6b 20 6c 6f 6f 70 20 77 69 74 68 6f 75 74 20 72 k loop without r
b020: 6f 74 61 74 69 6e 67 20 74 68 65 20 71 75 65 75 otating the queu
b030: 65 20 0a 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 68 e .. ;; (loop h
b040: 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e ed tal reg rerun
b050: 73 29 29 0a 09 20 20 3b 3b 20 28 6c 65 74 20 28 s)).. ;; (let (
b060: 28 6e 65 77 74 61 6c 20 28 61 70 70 65 6e 64 20 (newtal (append
b070: 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 tal (list hed)))
b080: 29 20 20 3b 3b 20 57 65 20 73 68 6f 75 6c 64 20 ) ;; We should
b090: 64 69 73 63 61 72 64 20 68 65 64 20 61 73 20 69 discard hed as i
b0a0: 74 20 68 61 73 20 62 65 65 6e 20 65 78 70 61 6e t has been expan
b0b0: 64 65 64 20 69 6e 74 6f 20 69 74 27 73 20 69 74 ded into it's it
b0c0: 65 6d 73 3f 20 59 65 73 2c 20 62 75 74 20 6f 6e ems? Yes, but on
b0d0: 6c 79 20 69 66 20 74 68 69 73 20 2a 69 73 2a 20 ly if this *is*
b0e0: 61 6e 20 69 74 65 6d 69 7a 65 64 20 74 65 73 74 an itemized test
b0f0: 0a 09 20 20 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 .. ;; (loop (ca
b100: 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 r newtal)(cdr ne
b110: 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 wtal) reg reruns
b120: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
b130: 74 61 6c 29 0a 09 20 20 20 20 20 20 23 66 0a 09 tal).. #f..
b140: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
b150: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 tal)(cdr tal) r
b160: 65 67 20 72 65 72 75 6e 73 29 29 29 0a 09 20 20 eg reruns)))..
b170: 20 20 0a 09 20 3b 3b 20 69 66 20 69 74 65 6d 73 .. ;; if items
b180: 20 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 is a proc then
b190: 6e 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d need to run item
b1a0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
b1b0: 2d 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 -config, get the
b1c0: 20 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a list and loop .
b1d0: 09 20 3b 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e . ;; - but on
b1e0: 6c 79 20 64 6f 20 74 68 61 74 20 69 66 20 72 65 ly do that if re
b1f0: 73 6f 75 72 63 65 73 20 65 78 69 73 74 20 74 6f sources exist to
b200: 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f kick off the jo
b210: 62 0a 09 20 3b 3b 20 45 58 50 41 4e 44 20 49 54 b.. ;; EXPAND IT
b220: 45 4d 53 0a 09 20 28 28 6f 72 20 28 70 72 6f 63 EMS.. ((or (proc
b230: 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 edure? items)(eq
b240: 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 ? items 'have-pr
b250: 6f 63 65 64 75 72 65 29 29 0a 09 20 20 28 6c 65 ocedure)).. (le
b260: 74 20 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 t ((can-run-more
b270: 20 20 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 (runs:can-ru
b280: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 6a 6f 62 n-more-tests job
b290: 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 group max-concur
b2a0: 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a 09 20 20 rent-jobs)))..
b2b0: 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 (if (and (list
b2c0: 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a ? can-run-more).
b2d0: 09 09 20 20 20 20 20 28 63 61 72 20 63 61 6e 2d .. (car can-
b2e0: 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 28 6c 65 run-more))...(le
b2f0: 74 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 20 28 72 t ((loop-list (r
b300: 75 6e 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d 73 uns:expand-items
b310: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
b320: 75 6e 73 20 72 65 67 66 75 6c 6c 20 6e 65 77 74 uns regfull newt
b330: 61 6c 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d al jobgroup max-
b340: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
b350: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 run-id waitons i
b360: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 6d 6f 64 tem-path testmod
b370: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 63 61 e test-record ca
b380: 6e 2d 72 75 6e 2d 6d 6f 72 65 20 69 74 65 6d 73 n-run-more items
b390: 20 72 75 6e 6e 61 6d 65 20 74 63 6f 6e 66 69 67 runname tconfig
b3a0: 20 72 65 67 6c 65 6e 20 74 65 73 74 2d 72 65 67 reglen test-reg
b3b0: 69 73 74 72 79 20 74 65 73 74 2d 72 65 63 6f 72 istry test-recor
b3c0: 64 73 29 29 29 0a 09 09 20 20 28 69 66 20 6c 6f ds)))... (if lo
b3d0: 6f 70 2d 6c 69 73 74 0a 09 09 20 20 20 20 20 20 op-list...
b3e0: 28 61 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 (apply loop loop
b3f0: 2d 6c 69 73 74 29 29 29 0a 09 09 3b 3b 20 69 66 -list)))...;; if
b400: 20 63 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 can't run more
b410: 6a 75 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e just loop with n
b420: 65 78 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 ext possible tes
b430: 74 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e t...(loop (car n
b440: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
b450: 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 29 29 l) reg reruns)))
b460: 29 0a 09 20 20 20 20 0a 09 20 3b 3b 20 74 68 69 ).. .. ;; thi
b470: 73 20 63 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f s case should no
b480: 74 20 68 61 70 70 65 6e 2c 20 61 64 64 65 64 20 t happen, added
b490: 74 6f 20 68 65 6c 70 20 63 61 74 63 68 20 61 6e to help catch an
b4a0: 79 20 62 75 67 73 0a 09 20 28 28 61 6e 64 20 28 y bugs.. ((and (
b4b0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
b4c0: 6d 64 61 74 29 0a 09 20 20 28 64 65 62 75 67 3a mdat).. (debug:
b4d0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
b4e0: 53 68 6f 75 6c 64 20 6e 6f 74 20 68 61 76 65 20 Should not have
b4f0: 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 73 20 a list of items
b500: 69 6e 20 61 20 74 65 73 74 20 61 6e 64 20 74 68 in a test and th
b510: 65 20 69 74 65 6d 73 70 61 74 68 20 73 65 74 20 e itemspath set
b520: 2d 20 70 6c 65 61 73 65 20 72 65 70 6f 72 74 20 - please report
b530: 74 68 69 73 22 29 0a 09 20 20 28 65 78 69 74 20 this").. (exit
b540: 31 29 29 0a 09 20 28 28 6e 6f 74 20 28 6e 75 6c 1)).. ((not (nul
b550: 6c 3f 20 72 65 72 75 6e 73 29 29 0a 09 20 20 28 l? reruns)).. (
b560: 6c 65 74 2a 20 28 28 6e 65 77 6c 73 74 20 28 74 let* ((newlst (t
b570: 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d ests:filter-non-
b580: 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 20 runnable run-id
b590: 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 73 tal test-records
b5a0: 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 20 46 )) ;; i.e. not F
b5b0: 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 49 4e 43 AIL, WAIVED, INC
b5c0: 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 2c 20 4b OMPLETE, PASS, K
b5d0: 49 4c 4c 45 44 2c 0a 09 09 20 28 6a 75 6e 6b 65 ILLED,... (junke
b5e0: 64 20 28 6c 73 65 74 2d 64 69 66 66 65 72 65 6e d (lset-differen
b5f0: 63 65 20 65 71 75 61 6c 3f 20 74 61 6c 20 6e 65 ce equal? tal ne
b600: 77 6c 73 74 29 29 29 0a 09 20 20 20 20 28 64 65 wlst))).. (de
b610: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
b620: 20 22 66 75 6c 6c 20 64 72 6f 70 20 74 68 72 6f "full drop thro
b630: 75 67 68 2c 20 69 66 20 72 65 72 75 6e 73 20 69 ugh, if reruns i
b640: 73 20 6c 65 73 73 20 74 68 61 6e 20 31 30 30 20 s less than 100
b650: 77 65 20 77 69 6c 6c 20 66 6f 72 63 65 20 72 65 we will force re
b660: 74 72 79 20 74 68 65 6d 2c 20 72 65 72 75 6e 73 try them, reruns
b670: 3d 22 20 72 65 72 75 6e 73 20 22 2c 20 74 61 6c =" reruns ", tal
b680: 3d 22 20 74 61 6c 29 0a 09 20 20 20 20 28 69 66 =" tal).. (if
b690: 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 (< num-retries
b6a0: 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 28 max-retries)...(
b6b0: 73 65 74 21 20 6e 65 77 6c 73 74 20 28 61 70 70 set! newlst (app
b6c0: 65 6e 64 20 72 65 72 75 6e 73 20 6e 65 77 6c 73 end reruns newls
b6d0: 74 29 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 t))).. (set!
b6e0: 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 6e num-retries (+ n
b6f0: 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 0a 09 um-retries 1))..
b700: 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 ;; (thread-s
b710: 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 leep! (+ 1 *glob
b720: 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 20 20 20 al-delta*))..
b730: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
b740: 20 6e 65 77 6c 73 74 29 29 0a 09 09 3b 3b 20 73 newlst))...;; s
b750: 69 6e 63 65 20 72 65 72 75 6e 73 20 68 61 76 65 ince reruns have
b760: 20 62 65 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 been tacked on
b770: 74 6f 20 6e 65 77 6c 73 74 20 63 72 65 61 74 65 to newlst create
b780: 20 6e 65 77 20 72 65 72 75 6e 73 20 66 72 6f 6d new reruns from
b790: 20 6a 75 6e 6b 65 64 0a 09 09 28 6c 6f 6f 70 20 junked...(loop
b7a0: 28 63 61 72 20 6e 65 77 6c 73 74 29 28 63 64 72 (car newlst)(cdr
b7b0: 20 6e 65 77 6c 73 74 29 20 72 65 67 20 28 64 65 newlst) reg (de
b7c0: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
b7d0: 6a 75 6e 6b 65 64 29 29 29 29 29 0a 09 20 28 28 junked))))).. ((
b7e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
b7f0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
b800: 2d 69 6e 66 6f 20 34 20 22 49 27 6d 20 70 72 65 -info 4 "I'm pre
b810: 74 74 79 20 73 75 72 65 20 49 20 73 68 6f 75 6c tty sure I shoul
b820: 64 6e 27 74 20 67 65 74 20 68 65 72 65 2e 22 29 dn't get here.")
b830: 29 0a 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ).. ((not (null?
b840: 20 72 65 67 29 29 20 3b 3b 20 63 6f 75 6c 64 20 reg)) ;; could
b850: 77 65 20 67 65 74 20 68 65 72 65 20 77 69 74 68 we get here with
b860: 20 6c 65 66 74 6f 76 65 72 73 3f 0a 09 20 20 28 leftovers?.. (
b870: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
b880: 20 30 20 22 48 61 76 65 20 6c 65 66 74 6f 76 65 0 "Have leftove
b890: 72 73 21 22 29 0a 09 20 20 28 6c 6f 6f 70 20 28 rs!").. (loop (
b8a0: 63 61 72 20 72 65 67 29 28 63 64 72 20 72 65 67 car reg)(cdr reg
b8b0: 29 20 27 28 29 20 72 65 72 75 6e 73 29 29 0a 09 ) '() reruns))..
b8c0: 20 28 65 6c 73 65 0a 09 20 20 28 64 65 62 75 67 (else.. (debug
b8d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 :print-info 4 "E
b8e0: 78 69 74 69 6e 67 20 6c 6f 6f 70 20 77 69 74 68 xiting loop with
b8f0: 2e 2e 2e 5c 6e 20 20 68 65 64 3d 22 20 68 65 64 ...\n hed=" hed
b900: 20 22 5c 6e 20 20 74 61 6c 3d 22 20 74 61 6c 20 "\n tal=" tal
b910: 22 5c 6e 20 20 72 65 72 75 6e 73 3d 22 20 72 65 "\n reruns=" re
b920: 72 75 6e 73 29 29 0a 09 20 29 29 29 20 3b 3b 20 runs)).. ))) ;;
b930: 4c 45 54 2a 20 28 28 74 65 73 74 2d 72 65 63 6f LET* ((test-reco
b940: 72 64 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 77 rd. . ;; w
b950: 65 20 67 65 74 20 68 65 72 65 20 6f 6e 20 22 64 e get here on "d
b960: 72 6f 70 20 74 68 72 6f 75 67 68 22 2e 20 41 6c rop through". Al
b970: 6c 20 64 6f 6e 65 21 0a 20 20 20 20 28 64 65 62 l done!. (deb
b980: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
b990: 22 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 "All tests launc
b9a0: 68 65 64 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 hed")))..(define
b9b0: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c (runs:calc-fail
b9c0: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
b9d0: 74 29 0a 20 20 28 66 69 6c 74 65 72 20 28 6c 61 t). (filter (la
b9e0: 6d 62 64 61 20 28 74 65 73 74 29 0a 09 20 20 20 mbda (test)..
b9f0: 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 (and (vector? t
ba00: 65 73 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 est) ;; not (str
ba10: 69 6e 67 3f 20 74 65 73 74 29 29 0a 09 09 20 28 ing? test))... (
ba20: 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
ba30: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 29 20 get-state test)
ba40: 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 20 "COMPLETED")...
ba50: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 (not (member (db
ba60: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
ba70: 20 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 20 test)....
ba80: 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 '("PASS" "WARN"
ba90: 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 "CHECK" "WAIVED"
baa0: 20 22 53 4b 49 50 22 29 29 29 29 29 0a 09 20 20 "SKIP")))))..
bab0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
bac0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
bad0: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
bae0: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
baf0: 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 met). (filter.
bb00: 20 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 (lambda (t).
bb10: 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 (or (not (vec
bb20: 74 6f 72 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 tor? t)).. (not
bb30: 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 (equal? "COMPLET
bb40: 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ED" (db:test-get
bb50: 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a 20 20 -state t))))).
bb60: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
bb70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
bb80: 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 s:pretty-string
bb90: 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d lst). (map (lam
bba0: 62 64 61 20 28 74 29 0a 09 20 28 69 66 20 28 6e bda (t).. (if (n
bbb0: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
bbc0: 09 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 . (conc t)..
bbd0: 20 20 20 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 (conc (db:t
bbe0: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
bbf0: 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 t) ":" (db:test
bc00: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
bc10: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
bc20: 74 61 74 75 73 20 74 29 29 29 29 0a 20 20 20 20 tatus t)))).
bc30: 20 20 20 6c 73 74 29 29 0a 0a 28 64 65 66 69 6e lst))..(defin
bc40: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
bc50: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
bc60: 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 name itempath).
bc70: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 (if (equal? ite
bc80: 6d 70 61 74 68 20 22 22 29 20 74 65 73 74 6e 61 mpath "") testna
bc90: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
bca0: 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 29 29 e "/" itempath))
bcb0: 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 )..;; parent-tes
bcc0: 74 20 69 73 20 74 68 65 72 65 20 61 73 20 61 20 t is there as a
bcd0: 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 placeholder for
bce0: 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 when parent-test
bcf0: 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 20 s can be run as
bd00: 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 65 a setup step.(de
bd10: 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 72 fine (run:test r
bd20: 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b un-id run-info k
bd30: 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 eyvals runname t
bd40: 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 est-record flags
bd50: 20 70 61 72 65 6e 74 2d 74 65 73 74 20 74 65 73 parent-test tes
bd60: 74 2d 72 65 67 69 73 74 72 79 20 61 6c 6c 2d 74 t-registry all-t
bd70: 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 ests-registry).
bd80: 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 61 ;; All these va
bd90: 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 66 65 rs might be refe
bda0: 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 74 65 renced by the te
bdb0: 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 stconfig file re
bdc0: 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 ader. (let* ((t
bdd0: 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 est-name (tes
bde0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
bdf0: 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 -testname test
be00: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 -record)).. (tes
be10: 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 t-waitons (tests
be20: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
be30: 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 aitons test-r
be40: 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d ecord)).. (test-
be50: 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 3a 74 conf (tests:t
be60: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
be70: 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 tconfig test-rec
be80: 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 61 74 ord)).. (itemdat
be90: 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 (tests:tes
bea0: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 tqueue-get-itemd
beb0: 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 at test-recor
bec0: 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 68 d)).. (test-path
bed0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
bee0: 72 65 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 ref all-tests-re
bef0: 67 69 73 74 72 79 20 74 65 73 74 2d 6e 61 6d 65 gistry test-name
bf00: 29 29 20 3b 3b 20 28 63 6f 6e 63 20 2a 74 6f 70 )) ;; (conc *top
bf10: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
bf20: 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 test-name)) ;; c
bf30: 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a 67 ould use tests:g
bf40: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
bf50: 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 re ..... (force
bf60: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
bf70: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
bf80: 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 66 lags "-force" #f
bf90: 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 20 )).. (rerun
bfa0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
bfb0: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
bfc0: 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a 09 "-rerun" #f))..
bfd0: 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 28 (keepgoing (
bfe0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
bff0: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b efault flags "-k
c000: 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 eepgoing" #f))..
c010: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 (item-path
c020: 22 22 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 "").. (db
c030: 20 20 20 20 23 66 29 0a 09 20 28 66 75 6c 6c 2d #f).. (full-
c040: 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 0a test-name #f))..
c050: 20 20 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 ;; setting i
c060: 74 65 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 temdat to a list
c070: 20 69 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 if it is #f.
c080: 20 28 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 (if (not itemda
c090: 74 29 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 t)(set! itemdat
c0a0: 27 28 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 '())). (set!
c0b0: 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d item-path (item-
c0c0: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
c0d0: 61 74 29 29 0a 20 20 20 20 28 73 65 74 21 20 66 at)). (set! f
c0e0: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 28 72 ull-test-name (r
c0f0: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
c100: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
c110: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 e item-path)).
c120: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
c130: 6e 66 6f 20 34 0a 09 09 20 20 20 20 20 20 22 5c nfo 4... "\
c140: 6e 54 45 53 54 4e 41 4d 45 3a 20 22 20 66 75 6c nTESTNAME: " ful
c150: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 0a 09 09 20 l-test-name ...
c160: 20 20 20 20 20 22 5c 6e 20 20 20 74 65 73 74 2d "\n test-
c170: 63 6f 6e 66 69 67 3a 20 22 20 28 68 61 73 68 2d config: " (hash-
c180: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 table->alist tes
c190: 74 2d 63 6f 6e 66 29 0a 09 09 20 20 20 20 20 20 t-conf)...
c1a0: 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a 20 22 "\n itemdat: "
c1b0: 20 69 74 65 6d 64 61 74 0a 09 09 20 20 20 20 20 itemdat...
c1c0: 20 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 ). (debug:pr
c1d0: 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 6e int 2 "Attemptin
c1e0: 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 g to launch test
c1f0: 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d " full-test-nam
c200: 65 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 e). (setenv "
c210: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
c220: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 st-name) ;; .
c230: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (setenv "MT_ITE
c240: 4d 50 41 54 48 22 20 20 69 74 65 6d 2d 70 61 74 MPATH" item-pat
c250: 68 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 h). (setenv "
c260: 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 MT_RUNNAME" ru
c270: 6e 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 74 2d nname). (set-
c280: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
c290: 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e 61 s run-id inrunna
c2a0: 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 me: runname) ;;
c2b0: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
c2c0: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
c2d0: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 hing process.
c2e0: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
c2f0: 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 ry *toppath*)..
c300: 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 ;; Here is wh
c310: 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ere the test_met
c320: 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 a table is best
c330: 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 updated. ;; Y
c340: 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 es, another use
c350: 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 of a global for
c360: 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 caching. Need a
c370: 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 better way?.
c380: 3b 3b 0a 20 20 20 20 3b 3b 20 54 68 65 72 65 20 ;;. ;; There
c390: 69 73 20 6e 6f 77 20 61 20 73 69 6e 67 6c 65 20 is now a single
c3a0: 63 61 6c 6c 20 74 6f 20 72 75 6e 73 3a 75 70 64 call to runs:upd
c3b0: 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 ate-all-test_met
c3c0: 61 20 61 6e 64 20 74 68 69 73 20 0a 20 20 20 20 a and this .
c3d0: 3b 3b 20 70 65 72 2d 74 65 73 74 20 63 61 6c 6c ;; per-test call
c3e0: 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 2e 20 is not needed.
c3f0: 47 69 76 65 6e 20 74 68 65 20 64 65 6c 69 63 61 Given the delica
c400: 63 79 20 6f 66 20 74 68 65 20 6d 6f 76 65 20 74 cy of the move t
c410: 6f 20 0a 20 20 20 20 3b 3b 20 76 31 2e 35 35 20 o . ;; v1.55
c420: 74 68 69 73 20 63 6f 64 65 20 69 73 20 62 65 69 this code is bei
c430: 6e 67 20 6c 65 66 74 20 69 6e 20 70 6c 61 63 65 ng left in place
c440: 20 66 6f 72 20 74 68 65 20 74 69 6d 65 20 62 65 for the time be
c450: 69 6e 67 2e 0a 20 20 20 20 3b 3b 0a 20 20 20 20 ing.. ;;.
c460: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
c470: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
c480: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
c490: 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 ted* test-name #
c4a0: 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 f)). (beg
c4b0: 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 in.. (hash-tab
c4c0: 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 le-set! *test-me
c4d0: 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 ta-updated* test
c4e0: 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 -name #t).
c4f0: 20 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 (runs:updat
c500: 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 e-test_meta test
c510: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
c520: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 )). . ;; i
c530: 74 65 6d 64 61 74 20 3d 3e 20 28 28 72 69 70 65 temdat => ((ripe
c540: 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 ness "overripe")
c550: 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 (temperature "c
c560: 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 ool") (season "s
c570: 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 ummer")). (le
c580: 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 t* ((new-test-pa
c590: 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 th (string-inter
c5a0: 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 sperse (cons tes
c5b0: 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 t-path (map cadr
c5c0: 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 itemdat)) "/"))
c5d0: 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
c5e0: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
c5f0: 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 2d run db:get-test-
c600: 69 64 2d 63 61 63 68 65 64 20 23 66 20 20 72 75 id-cached #f ru
c610: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
c620: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 28 tem-path)).. (
c630: 74 65 73 74 64 61 74 20 20 20 20 20 20 20 28 69 testdat (i
c640: 66 20 74 65 73 74 2d 69 64 20 28 63 64 62 3a 67 f test-id (cdb:g
c650: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
c660: 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 id *runremote* t
c670: 65 73 74 2d 69 64 29 20 23 66 29 29 29 0a 20 20 est-id) #f))).
c680: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 (if (not tes
c690: 74 64 61 74 29 0a 09 20 20 28 6c 65 74 20 6c 6f tdat).. (let lo
c6a0: 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b 20 65 6e op ().. ;; en
c6b0: 73 75 72 65 20 74 68 61 74 20 74 68 65 20 70 61 sure that the pa
c6c0: 74 68 20 65 78 69 73 74 73 20 62 65 66 6f 72 65 th exists before
c6d0: 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 68 65 registering the
c6e0: 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 4e 4f test.. ;; NO
c6f0: 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f 6e 27 PE: Cannot! Don'
c700: 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 63 68 t know yet which
c710: 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c 6c 20 disk area will
c720: 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e 2e 0a be assigned.....
c730: 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 . ;; (system
c740: 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d 70 20 (conc "mkdir -p
c750: 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 29 " new-test-path)
c760: 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b ).. ;;.. ;
c770: 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 ; (open-run-clos
c780: 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 e tests:register
c790: 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 -test db run-id
c7a0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
c7b0: 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 ath).. ;;..
c7c0: 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 74 68 ;; NB// for th
c7d0: 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 49 20 e above line. I
c7e0: 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 74 6f want the test to
c7f0: 20 62 65 20 72 65 67 69 73 74 65 72 65 64 20 6c be registered l
c800: 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 73 20 ong before this
c810: 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 61 6c routine gets cal
c820: 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 20 20 led!.. ;;..
c830: 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 2d (if (not test-
c840: 69 64 29 28 73 65 74 21 20 74 65 73 74 2d 69 64 id)(set! test-id
c850: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
c860: 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 2d db:get-test-id-
c870: 63 61 63 68 65 64 20 23 66 20 72 75 6e 2d 69 64 cached #f run-id
c880: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
c890: 70 61 74 68 29 29 29 0a 09 20 20 20 20 28 69 66 path))).. (if
c8a0: 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 0a 09 (not test-id)..
c8b0: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
c8c0: 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 52 4e ug:print 2 "WARN
c8d0: 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 2d 63 : Test not pre-c
c8e0: 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e 61 6d reated? test-nam
c8f0: 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c e=" test-name ",
c900: 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 74 65 item-path=" ite
c910: 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d 69 64 m-path ", run-id
c920: 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 =" run-id)... (
c930: 63 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 74 cdb:tests-regist
c940: 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 65 6d 6f er-test *runremo
c950: 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 74 2d te* run-id test-
c960: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
c970: 09 09 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 .. (set! test-i
c980: 64 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 d (cdb:remote-ru
c990: 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 n db:get-test-id
c9a0: 2d 63 61 63 68 65 64 20 23 66 20 72 75 6e 2d 69 -cached #f run-i
c9b0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
c9c0: 2d 70 61 74 68 29 29 29 29 0a 09 20 20 20 20 28 -path)))).. (
c9d0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
c9e0: 20 34 20 22 74 65 73 74 2d 69 64 3d 22 20 74 65 4 "test-id=" te
c9f0: 73 74 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d st-id ", run-id=
ca00: 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 " run-id ", test
ca10: 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d -name=" test-nam
ca20: 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c e ", item-path=\
ca30: 22 22 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 "" item-path "\"
ca40: 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 ").. (set! te
ca50: 73 74 64 61 74 20 28 63 64 62 3a 67 65 74 2d 74 stdat (cdb:get-t
ca60: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a est-info-by-id *
ca70: 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d runremote* test-
ca80: 69 64 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e id)).. (if (n
ca90: 6f 74 20 74 65 73 74 64 61 74 29 0a 09 09 28 62 ot testdat)...(b
caa0: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
cab0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 41 print-info 0 "WA
cac0: 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 69 73 RNING: server is
cad0: 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 74 72 79 overloaded, try
cae0: 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 6f 6e 65 ing again in one
caf0: 20 73 65 63 6f 6e 64 22 29 0a 09 09 20 20 28 74 second")... (t
cb00: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
cb10: 09 09 20 20 28 6c 6f 6f 70 29 29 29 29 29 0a 20 .. (loop))))).
cb20: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
cb30: 73 74 64 61 74 29 20 3b 3b 20 73 68 6f 75 6c 64 stdat) ;; should
cb40: 20 4e 4f 54 20 68 61 70 70 65 6e 0a 09 20 20 28 NOT happen.. (
cb50: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
cb60: 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 RROR: failed to
cb70: 67 65 74 20 74 65 73 74 20 72 65 63 6f 72 64 20 get test record
cb80: 66 6f 72 20 74 65 73 74 2d 69 64 20 22 20 74 65 for test-id " te
cb90: 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 73 st-id)). (s
cba0: 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a et! test-id (db:
cbb0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
cbc0: 64 61 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 dat)). (if
cbd0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
cbe0: 73 74 2d 70 61 74 68 29 0a 09 20 20 28 63 68 61 st-path).. (cha
cbf0: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 nge-directory te
cc00: 73 74 2d 70 61 74 68 29 0a 09 20 20 28 62 65 67 st-path).. (beg
cc10: 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 in.. (debug:p
cc20: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 65 73 rint "ERROR: tes
cc30: 74 20 72 75 6e 20 70 61 74 68 20 6e 6f 74 20 63 t run path not c
cc40: 72 65 61 74 65 64 20 62 65 66 6f 72 65 20 61 74 reated before at
cc50: 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 75 6e 20 tempting to run
cc60: 74 68 65 20 74 65 73 74 2e 20 50 65 72 68 61 70 the test. Perhap
cc70: 73 20 79 6f 75 20 61 72 65 20 72 75 6e 6e 69 6e s you are runnin
cc80: 67 20 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 20 61 g -remove-runs a
cc90: 74 20 74 68 65 20 73 61 6d 65 20 74 69 6d 65 3f t the same time?
cca0: 22 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 2d ").. (change-
ccb0: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
ccc0: 74 68 2a 29 29 29 0a 20 20 20 20 20 20 28 63 61 th*))). (ca
ccd0: 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 se (if force ;;
cce0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
ccf0: 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 force")...'NOT_S
cd00: 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 TARTED...(if tes
cd10: 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 tdat... (stri
cd20: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 ng->symbol (test
cd30: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
cd40: 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c at))... 'fail
cd50: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 ed-to-insert))..
cd60: 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 ((failed-to-inse
cd70: 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 rt).. (debug:pri
cd80: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
cd90: 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 led to insert th
cda0: 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 e record into th
cdb0: 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 e db"))..((NOT_S
cdc0: 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 TARTED COMPLETED
cdd0: 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 DELETED).. (let
cde0: 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a ((runflag #f)).
cdf0: 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b . (cond.. ;
ce00: 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f ; -force, run no
ce10: 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 matter what..
ce20: 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 (force (set! r
ce30: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
ce40: 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c ;; NOT_STARTED,
ce50: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
ce60: 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 hat.. ((membe
ce70: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
ce80: 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 45 e testdat) '("DE
ce90: 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 LETED" "NOT_STAR
cea0: 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e 66 TED"))(set! runf
ceb0: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
cec0: 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 not -rerun and
ced0: 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 PASS, WARN or CH
cee0: 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 ECK, do no run..
cef0: 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e ((and (or (n
cf00: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 ot rerun)...
cf10: 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 keepgoing)...
cf20: 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 ;; Require to f
cf30: 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 orce re-run for
cf40: 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e COMPLETED or *an
cf50: 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 ything* + PASS,W
cf60: 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 ARN or CHECK...
cf70: 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 (or (member (te
cf80: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
cf90: 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 stdat) '("PASS"
cfa0: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 "WARN" "CHECK" "
cfb0: 53 4b 49 50 22 20 22 57 41 49 56 45 44 22 29 29 SKIP" "WAIVED"))
cfc0: 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
cfd0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
cfe0: 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 4f testdat) '("CO
cff0: 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 MPLETED")))) ..
d000: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
d010: 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 -info 2 "running
d020: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
d030: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 e "/" item-path
d040: 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 20 " suppressed as
d050: 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 it is " (test:ge
d060: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
d070: 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 " and " (test:g
d080: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
d090: 74 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d t)).. (hash-
d0a0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
d0b0: 72 65 67 69 73 74 72 79 20 66 75 6c 6c 2d 74 65 registry full-te
d0c0: 73 74 2d 6e 61 6d 65 20 27 44 4f 4e 4f 54 52 55 st-name 'DONOTRU
d0d0: 4e 29 20 3b 3b 20 43 4f 4d 50 4c 45 54 45 44 29 N) ;; COMPLETED)
d0e0: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
d0f0: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b flag #f)).. ;
d100: 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 ; -rerun and sta
d110: 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 tus is one of th
d120: 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 e specifed, run
d130: 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 it.. ((and re
d140: 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 run... (let* ((
d150: 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 rerunlst (stri
d160: 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 ng-split rerun "
d170: 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 ,")).... (must-r
d180: 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 erun (member (te
d190: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
d1a0: 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 stdat) rerunlst)
d1b0: 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a ))... (debug:
d1c0: 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d 72 print-info 3 "-r
d1d0: 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 erun list: " rer
d1e0: 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 un ", test-statu
d1f0: 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 s: " (test:get-s
d200: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 22 2c tatus testdat)",
d210: 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d must-rerun: " m
d220: 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 ust-rerun)...
d230: 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 must-rerun))..
d240: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
d250: 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 66 -info 2 "Rerun f
d260: 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 orced for test "
d270: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
d280: 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 tem-path)..
d290: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
d2a0: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 )).. ;; -keep
d2b0: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
d2c0: 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 run FAIL.. ((
d2d0: 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 and keepgoing...
d2e0: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
d2f0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
d300: 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a at) '("FAIL"))).
d310: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
d320: 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 lag #f)).. ((
d330: 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a and (not rerun).
d340: 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 .. (member (tes
d350: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
d360: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
d370: 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 n/a"))).. (s
d380: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
d390: 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 .. (else (set
d3a0: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a ! runflag #f))).
d3b0: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
d3c0: 20 34 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 4 "RUNNING => r
d3d0: 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 unflag: " runfla
d3e0: 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 g " STATE: " (te
d3f0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
d400: 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 tdat) " STATUS:
d410: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
d420: 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 us testdat))..
d430: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 (if (not runfla
d440: 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 g).. (if (
d450: 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 not parent-test)
d460: 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
d470: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 nt 1 "NOTE: Not
d480: 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 starting test "
d490: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 full-test-name "
d4a0: 20 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 as it is state
d4b0: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
d4c0: 61 74 65 20 74 65 73 74 64 61 74 29 20 0a 09 09 ate testdat) ...
d4d0: 09 09 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 .."\" and status
d4e0: 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 \"" (test:get-s
d4f0: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 tatus testdat) "
d500: 5c 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c \", use -rerun \
d510: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
d520: 74 75 73 20 74 65 73 74 64 61 74 29 0a 20 20 20 tus testdat).
d530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d540: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 22 "\"
d550: 20 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 or -force to ov
d560: 65 72 72 69 64 65 22 29 29 0a 09 20 20 20 20 20 erride"))..
d570: 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f ;; NOTE: No lo
d580: 6e 67 65 72 20 62 65 20 63 68 65 63 6b 69 6e 67 nger be checking
d590: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 68 prerequisites h
d5a0: 65 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 20 ere! Will never
d5b0: 67 65 74 20 68 65 72 65 20 75 6e 6c 65 73 73 20 get here unless
d5c0: 70 72 65 72 65 71 73 20 61 72 65 0a 09 20 20 20 prereqs are..
d5d0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 61 6c 72 ;; alr
d5e0: 65 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 20 eady met...
d5f0: 20 20 3b 3b 20 54 68 69 73 20 77 6f 75 6c 64 20 ;; This would
d600: 62 65 20 61 20 67 72 65 61 74 20 70 6c 61 63 65 be a great place
d610: 20 74 6f 20 64 6f 20 74 68 65 20 70 72 6f 63 65 to do the proce
d620: 73 73 2d 66 6f 72 6b 0a 09 20 20 20 20 20 20 20 ss-fork..
d630: 3b 3b 20 0a 09 20 20 20 20 20 20 20 28 6c 65 74 ;; .. (let
d640: 20 28 28 73 6b 69 70 2d 74 65 73 74 20 20 20 23 ((skip-test #
d650: 66 29 0a 09 09 20 20 20 20 20 28 73 6b 69 70 2d f)... (skip-
d660: 63 68 65 63 6b 20 20 28 63 6f 6e 66 69 67 66 3a check (configf:
d670: 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 65 73 74 get-section test
d680: 2d 63 6f 6e 66 20 22 73 6b 69 70 22 29 29 29 0a -conf "skip"))).
d690: 09 09 20 28 63 6f 6e 64 20 0a 09 09 20 20 3b 3b .. (cond ... ;;
d6a0: 20 48 61 76 65 20 74 6f 20 63 68 65 63 6b 20 66 Have to check f
d6b0: 6f 72 20 73 6b 69 70 20 63 6f 6e 64 69 74 69 6f or skip conditio
d6c0: 6e 73 2e 20 54 68 69 73 20 6f 6e 65 20 73 6b 69 ns. This one ski
d6d0: 70 73 20 69 66 20 74 68 65 72 65 20 61 72 65 20 ps if there are
d6e0: 73 61 6d 65 2d 6e 61 6d 65 64 20 74 65 73 74 73 same-named tests
d6f0: 0a 09 09 20 20 3b 3b 20 63 75 72 72 65 6e 74 6c ... ;; currentl
d700: 79 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 28 28 y running... ((
d710: 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a 09 and skip-check..
d720: 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ..(configf:looku
d730: 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 p test-conf "ski
d740: 70 22 20 22 70 72 65 76 72 75 6e 6e 69 6e 67 22 p" "prevrunning"
d750: 29 29 0a 09 09 20 20 20 28 6c 65 74 20 28 28 72 ))... (let ((r
d760: 75 6e 6e 69 6e 67 2d 74 65 73 74 73 20 28 63 64 unning-tests (cd
d770: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
d780: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
d790: 6e 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 23 66 ns-mindata #f #f
d7a0: 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 full-test-name
d7b0: 27 28 22 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d '("RUNNING" "REM
d7c0: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 4c OTEHOSTSTART" "L
d7d0: 41 55 4e 43 48 45 44 22 29 20 27 28 29 20 23 66 AUNCHED") '() #f
d7e0: 29 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 )))... (if (
d7f0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 not (null? runni
d800: 6e 67 2d 74 65 73 74 73 29 29 20 3b 3b 20 68 61 ng-tests)) ;; ha
d810: 76 65 20 74 6f 20 73 6b 69 70 20 0a 09 09 09 20 ve to skip ....
d820: 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 74 20 (set! skip-test
d830: 22 53 6b 69 70 70 69 6e 67 20 64 75 65 20 74 6f "Skipping due to
d840: 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 73 20 previous tests
d850: 72 75 6e 6e 69 6e 67 22 29 29 29 29 0a 09 09 20 running"))))...
d860: 20 28 28 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 ((and skip-chec
d870: 6b 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f k....(configf:lo
d880: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 okup test-conf "
d890: 73 6b 69 70 22 20 22 66 69 6c 65 65 78 69 73 74 skip" "fileexist
d8a0: 73 22 29 29 0a 09 09 20 20 20 28 69 66 20 28 66 s"))... (if (f
d8b0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e ile-exists? (con
d8c0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 figf:lookup test
d8d0: 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 69 -conf "skip" "fi
d8e0: 6c 65 65 78 69 73 74 73 22 29 29 0a 09 09 20 20 leexists"))...
d8f0: 20 20 20 20 20 28 73 65 74 21 20 73 6b 69 70 2d (set! skip-
d900: 74 65 73 74 20 28 63 6f 6e 63 20 22 53 6b 69 70 test (conc "Skip
d910: 70 69 6e 67 20 64 75 65 20 74 6f 20 65 78 69 73 ping due to exis
d920: 74 61 6e 63 65 20 6f 66 20 66 69 6c 65 20 22 20 tance of file "
d930: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
d940: 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 test-conf "skip"
d950: 20 22 66 69 6c 65 65 78 69 73 74 73 22 29 29 29 "fileexists")))
d960: 29 29 29 0a 09 09 20 28 69 66 20 73 6b 69 70 2d )))... (if skip-
d970: 74 65 73 74 0a 09 09 20 20 20 20 20 28 62 65 67 test... (beg
d980: 69 6e 0a 09 09 20 20 20 20 20 20 20 28 6d 74 3a in... (mt:
d990: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
d9a0: 74 61 74 75 73 2d 62 79 2d 69 64 20 74 65 73 74 tatus-by-id test
d9b0: 2d 69 64 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 -id "COMPLETED"
d9c0: 22 53 4b 49 50 22 20 73 6b 69 70 2d 74 65 73 74 "SKIP" skip-test
d9d0: 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 )... (debu
d9e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
d9f0: 53 4b 49 50 50 49 4e 47 20 54 65 73 74 20 22 20 SKIPPING Test "
da00: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 full-test-name "
da10: 20 64 75 65 20 74 6f 20 22 20 73 6b 69 70 2d 74 due to " skip-t
da20: 65 73 74 29 29 0a 09 09 20 20 20 20 20 28 69 66 est))... (if
da30: 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 (not (launch-te
da40: 73 74 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 st test-id run-i
da50: 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 d run-info keyva
da60: 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d ls runname test-
da70: 63 6f 6e 66 20 74 65 73 74 2d 6e 61 6d 65 20 74 conf test-name t
da80: 65 73 74 2d 70 61 74 68 20 69 74 65 6d 64 61 74 est-path itemdat
da90: 20 66 6c 61 67 73 29 29 0a 09 09 09 20 28 62 65 flags)).... (be
daa0: 67 69 6e 0a 09 09 09 20 20 20 28 70 72 69 6e 74 gin.... (print
dab0: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
dac0: 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 to launch the te
dad0: 73 74 2e 20 45 78 69 74 69 6e 67 20 61 73 20 73 st. Exiting as s
dae0: 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 22 oon as possible"
daf0: 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 2a 67 ).... (set! *g
db00: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
db10: 20 31 29 20 3b 3b 20 0a 09 09 09 20 20 20 28 70 1) ;; .... (p
db20: 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 rocess-signal (c
db30: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
db40: 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 d) signal/kill))
db50: 29 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 ))))))..((KILLED
db60: 29 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e ) .. (debug:prin
db70: 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 66 75 6c t 1 "NOTE: " ful
db80: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 l-test-name " is
db90: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
dba0: 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c or was explictl
dbb0: 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 y killed, use -f
dbc0: 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 orce to launch i
dbd0: 74 2e 22 29 0a 09 20 28 68 61 73 68 2d 74 61 62 t.").. (hash-tab
dbe0: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
dbf0: 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 istry (runs:make
dc00: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name
dc10: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
dc20: 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 ath) 'DONOTRUN))
dc30: 20 3b 3b 20 4b 49 4c 4c 45 44 29 29 0a 09 28 28 ;; KILLED))..((
dc40: 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 LAUNCHED REMOTEH
dc50: 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 OSTSTART RUNNING
dc60: 29 20 20 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 ) .. (if (> (-
dc70: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
dc80: 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 )(+ (db:test-get
dc90: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 -event_time test
dca0: 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 20 20 dat).....
dcb0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
dcc0: 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 61 _duration testda
dcd0: 74 29 29 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 t)))...600) ;; i
dce0: 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 6f .e. no update fo
dcf0: 72 20 6d 6f 72 65 20 74 68 61 6e 20 36 30 30 20 r more than 600
dd00: 73 65 63 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 seconds.. (b
dd10: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 egin.. (de
dd20: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
dd30: 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 NING: Test " tes
dd40: 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 t-name " appears
dd50: 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 to be dead. For
dd60: 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 cing it to state
dd70: 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 INCOMPLETE and
dd80: 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 status STUCK/DEA
dd90: 44 22 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 D").. (tes
dda0: 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ts:test-set-stat
ddb0: 75 73 21 20 74 65 73 74 2d 69 64 20 22 49 4e 43 us! test-id "INC
ddc0: 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f OMPLETE" "STUCK/
ddd0: 44 45 41 44 22 20 22 54 65 73 74 20 69 73 20 73 DEAD" "Test is s
dde0: 74 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 tuck or dead" #f
ddf0: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
de00: 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 print 2 "NOTE: "
de10: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 test-name " is
de20: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 already running"
de30: 29 29 29 0a 09 28 65 6c 73 65 20 20 20 20 20 20 )))..(else
de40: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
de50: 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 0 "ERROR: Failed
de60: 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 to launch test
de70: 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 " full-test-name
de80: 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 ". Unrecognised
de90: 20 73 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 state " (test:g
dea0: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
deb0: 29 29 0a 09 20 28 63 61 73 65 20 28 73 74 72 69 )).. (case (stri
dec0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 ng->symbol (test
ded0: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
dee0: 61 74 29 29 20 0a 09 20 20 20 28 28 43 4f 4d 50 at)) .. ((COMP
def0: 4c 45 54 45 44 20 49 4e 43 4f 4d 50 4c 45 54 45 LETED INCOMPLETE
df00: 29 0a 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ).. (hash-tab
df10: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
df20: 69 73 74 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 istry (runs:make
df30: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name
df40: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
df50: 61 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 ath) 'DONOTRUN))
df60: 0a 09 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 .. (else..
df70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
df80: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 test-registry (
df90: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
dfa0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
dfb0: 6d 65 20 74 65 73 74 2d 70 61 74 68 29 20 27 44 me test-path) 'D
dfc0: 4f 4e 4f 54 52 55 4e 29 29 29 29 29 29 29 29 0a ONOTRUN)))))))).
dfd0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
dfe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 =========.;; END
e020: 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b OF NEW STUFF.;;
e030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e070: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
e080: 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 (get-dir-up-n di
e090: 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 r . params) . (
e0a0: 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 73 let ((dparts (s
e0b0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 tring-split dir
e0c0: 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 "/"))..(count
e0d0: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
e0e0: 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 s) 1 (car params
e0f0: 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 )))). (conc "
e100: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
e110: 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 sperse ..
e120: 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 (take dparts (-
e130: 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 (length dparts)
e140: 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 count))..
e150: 22 2f 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 "/"))))..(define
e160: 20 28 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 (runs:recursive
e170: 2d 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 -delete-with-err
e180: 6f 72 2d 6d 73 67 20 72 65 61 6c 2d 64 69 72 29 or-msg real-dir)
e190: 0a 20 20 28 69 66 20 28 3e 20 28 73 79 73 74 65 . (if (> (syste
e1a0: 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 m (conc "rm -rf
e1b0: 22 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a " real-dir)) 0).
e1c0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
e1d0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 nt 0 "ERROR: The
e1e0: 72 65 20 77 61 73 20 61 20 70 72 6f 62 6c 65 6d re was a problem
e1f0: 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c removing " real
e200: 2d 64 69 72 20 22 20 77 69 74 68 20 72 6d 20 2d -dir " with rm -
e210: 66 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 f")))..(define (
e220: 72 75 6e 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 runs:safe-delete
e230: 2d 74 65 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 -test-dir real-d
e240: 69 72 29 0a 20 20 3b 3b 20 66 69 72 73 74 20 64 ir). ;; first d
e250: 65 6c 65 74 65 20 61 6c 6c 20 73 75 62 2d 64 69 elete all sub-di
e260: 72 65 63 74 6f 72 69 65 73 0a 20 20 28 64 69 72 rectories. (dir
e270: 65 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 ectory-fold .
e280: 28 6c 61 6d 62 64 61 20 28 66 20 78 29 0a 20 20 (lambda (f x).
e290: 20 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 (let ((fullna
e2a0: 6d 65 20 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 me (conc real-di
e2b0: 72 20 22 2f 22 20 66 29 29 29 0a 20 20 20 20 20 r "/" f))).
e2c0: 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
e2d0: 3f 20 66 75 6c 6c 6e 61 6d 65 29 28 72 75 6e 73 ? fullname)(runs
e2e0: 3a 72 65 63 75 72 73 69 76 65 2d 64 65 6c 65 74 :recursive-delet
e2f0: 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 e-with-error-msg
e300: 20 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 fullname))).
e310: 20 20 28 2b 20 31 20 78 29 29 0a 20 20 20 30 20 (+ 1 x)). 0
e320: 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 real-dir). ;; t
e330: 68 65 6e 20 66 69 6c 65 73 20 6f 74 68 65 72 20 hen files other
e340: 74 68 61 6e 20 2a 74 65 73 74 64 61 74 2e 64 62 than *testdat.db
e350: 2a 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 *. (directory-f
e360: 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 old . (lambda
e370: 28 66 20 78 29 0a 20 20 20 20 20 28 6c 65 74 20 (f x). (let
e380: 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 ((fullname (conc
e390: 20 72 65 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 real-dir "/" f)
e3a0: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e )). (if (n
e3b0: 6f 74 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 ot (string-searc
e3c0: 68 20 28 72 65 67 65 78 70 20 22 74 65 73 74 64 h (regexp "testd
e3d0: 61 74 2e 64 62 22 29 20 66 29 29 0a 09 20 20 20 at.db") f))..
e3e0: 28 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d (runs:recursive-
e3f0: 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f delete-with-erro
e400: 72 2d 6d 73 67 20 66 75 6c 6c 6e 61 6d 65 29 29 r-msg fullname))
e410: 29 0a 20 20 20 20 20 28 2b 20 31 20 78 29 29 0a ). (+ 1 x)).
e420: 20 20 20 30 20 72 65 61 6c 2d 64 69 72 29 0a 20 0 real-dir).
e430: 20 3b 3b 20 74 68 65 6e 20 74 68 65 20 65 6e 74 ;; then the ent
e440: 69 72 65 20 64 69 72 65 63 74 6f 72 79 0a 20 20 ire directory.
e450: 28 72 75 6e 73 3a 72 65 63 75 72 73 69 76 65 2d (runs:recursive-
e460: 64 65 6c 65 74 65 2d 77 69 74 68 2d 65 72 72 6f delete-with-erro
e470: 72 2d 6d 73 67 20 72 65 61 6c 2d 64 69 72 29 29 r-msg real-dir))
e480: 0a 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 ..;; Remove runs
e490: 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 .;; fields are p
e4a0: 61 73 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 assing in throug
e4b0: 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b h .;; action:.;;
e4c0: 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 'remove-runs
e4d0: 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 .;; 'set-stat
e4e0: 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e e-status.;;.;; N
e4f0: 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 B// should pass
e500: 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 in keys?.;;.(def
e510: 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 ine (runs:operat
e520: 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 e-on action targ
e530: 65 74 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 et runnamepatt t
e540: 65 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 estpatt #!key (s
e550: 74 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 tate #f)(status
e560: 23 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 #f)(new-state-st
e570: 61 74 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d atus #f)). (com
e580: 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 mon:clear-caches
e590: 29 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 ) ;; clear all c
e5a0: 61 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 aches. (let* ((
e5b0: 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 db #f)
e5c0: 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 .. (keys
e5d0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
e5e0: 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 db:get-keys db)
e5f0: 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 ).. (rundat
e600: 20 20 28 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 (mt:get-runs-b
e610: 79 2d 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e y-patt keys runn
e620: 61 6d 65 70 61 74 74 20 74 61 72 67 65 74 29 29 amepatt target))
e630: 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 20 20 .. (header
e640: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
e650: 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 dat 0)).. (runs
e660: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
e670: 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 ref rundat 1))..
e680: 20 28 73 74 61 74 65 73 20 20 20 20 20 20 20 28 (states (
e690: 69 66 20 73 74 61 74 65 20 20 28 73 74 72 69 6e if state (strin
e6a0: 67 2d 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 g-split state "
e6b0: 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 ,") '())).. (sta
e6c0: 74 75 73 65 73 20 20 20 20 20 28 69 66 20 73 74 tuses (if st
e6d0: 61 74 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c atus (string-spl
e6e0: 69 74 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 it status ",") '
e6f0: 28 29 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 ())).. (state-st
e700: 61 74 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 atus (if (string
e710: 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 ? new-state-stat
e720: 75 73 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 us) (string-spli
e730: 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 t new-state-stat
e740: 75 73 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 us ",") '(#f #f)
e750: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
e760: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e rint-info 4 "run
e770: 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 s:operate-on =>
e780: 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 Header: " header
e790: 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 " action: " act
e7a0: 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d ion " new-state-
e7b0: 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 status: " new-st
e7c0: 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 ate-status).
e7d0: 28 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 74 68 (if (> 2 (length
e7e0: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a state-status)).
e7f0: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
e800: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
e810: 3a 20 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 : the parameter
e820: 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 to -set-state-st
e830: 61 74 75 73 20 69 73 20 61 20 63 6f 6d 6d 61 20 atus is a comma
e840: 64 65 6c 69 6d 69 74 65 64 20 73 74 72 69 6e 67 delimited string
e850: 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 45 44 . E.g. COMPLETED
e860: 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 78 69 74 ,FAIL").. (exit
e870: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
e880: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
e890: 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 run). (let
e8a0: 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e ((runkey (strin
e8b0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
e8c0: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 ap (lambda (k)..
e8d0: 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c .....(db:get-val
e8e0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
e8f0: 20 68 65 61 64 65 72 20 6b 29 29 20 6b 65 79 73 header k)) keys
e900: 29 20 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 ) "/")).. (d
e910: 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d irs-to-remove (m
e920: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
e930: 0a 09 20 20 20 20 20 28 70 72 6f 63 2d 67 65 74 .. (proc-get
e940: 2d 74 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 -tests (lambda (
e950: 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 20 20 run-id)....
e960: 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (mt:get-tests-f
e970: 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 0a 09 09 or-run run-id...
e980: 09 09 09 09 20 20 20 20 74 65 73 74 70 61 74 74 .... testpatt
e990: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 states statuses
e9a0: 0a 09 09 09 09 09 09 20 20 20 20 6e 6f 74 2d 69 ....... not-i
e9b0: 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 n: #f.......
e9c0: 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 sort-by: (case
e9d0: 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 20 20 action........
e9e0: 20 20 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 ((remove-ru
e9f0: 6e 73 29 20 27 72 75 6e 64 69 72 29 0a 09 09 09 ns) 'rundir)....
ea00: 09 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 .... (else
ea10: 20 20 20 20 20 20 20 20 20 20 27 65 76 65 6e 74 'event
ea20: 5f 74 69 6d 65 29 29 29 29 29 29 0a 09 20 28 6c _time)))))).. (l
ea30: 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 et* ((run-id
ea40: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
ea50: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
ea60: 65 72 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e er "id"))...(run
ea70: 2d 73 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 -state (db:get-v
ea80: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
ea90: 75 6e 20 68 65 61 64 65 72 20 22 73 74 61 74 65 un header "state
eaa0: 22 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 "))...(tests
eab0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
eac0: 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 ? run-state "loc
ead0: 6b 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 ked"))....
eae0: 20 28 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 (proc-get-tests
eaf0: 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 20 20 run-id)....
eb00: 20 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 74 '()))...(last
eb10: 74 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 tpath "/does/not
eb20: 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 /exist/I/hope"))
eb30: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
eb40: 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f t-info 4 "runs:o
eb50: 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 perate-on run="
eb60: 72 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 20 run ", header="
eb70: 68 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 20 header).. (if
eb80: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
eb90: 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 s)).. (beg
eba0: 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 69 in... (case acti
ebb0: 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 65 on... ((remove
ebc0: 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 28 64 65 -runs)... (de
ebd0: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
ebe0: 6f 76 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 oving tests for
ebf0: 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 run: " runkey "
ec00: 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d " (db:get-value-
ec10: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
ec20: 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 ader "runname"))
ec30: 29 0a 09 09 20 20 20 28 28 73 65 74 2d 73 74 61 )... ((set-sta
ec40: 74 65 2d 73 74 61 74 75 73 29 0a 09 09 20 20 20 te-status)...
ec50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
ec60: 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 61 74 65 "Modifying state
ec70: 20 61 6e 64 20 73 74 61 75 73 20 66 6f 72 20 74 and staus for t
ec80: 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 ests for run: "
ec90: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
eca0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
ecb0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
ecc0: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 unname")))...
ecd0: 28 28 70 72 69 6e 74 2d 72 75 6e 29 0a 09 09 20 ((print-run)...
ece0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
ecf0: 31 20 22 50 72 69 6e 74 69 6e 67 20 69 6e 66 6f 1 "Printing info
ed00: 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 for run " runke
ed10: 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 6e 20 22 y ", run=" run "
ed20: 2c 20 74 65 73 74 73 3d 22 20 74 65 73 74 73 20 , tests=" tests
ed30: 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 ", header=" head
ed40: 65 72 29 0a 09 09 20 20 20 20 61 63 74 69 6f 6e er)... action
ed50: 29 0a 09 09 20 20 20 28 28 72 75 6e 2d 77 61 69 )... ((run-wai
ed60: 74 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a t)... (debug:
ed70: 70 72 69 6e 74 20 31 20 22 57 61 69 74 69 6e 67 print 1 "Waiting
ed80: 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 for run " runke
ed90: 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 6e 6e 61 y ", run=" runna
eda0: 6d 65 70 61 74 74 20 22 20 74 6f 20 63 6f 6d 70 mepatt " to comp
edb0: 6c 65 74 65 22 29 29 0a 09 09 20 20 20 28 65 6c lete"))... (el
edc0: 73 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a se... (debug:
edd0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 print-info 0 "ac
ede0: 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 tion not recogni
edf0: 73 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a sed " action))).
ee00: 09 09 20 28 6c 65 74 20 28 28 73 6f 72 74 65 64 .. (let ((sorted
ee10: 2d 74 65 73 74 73 20 20 20 20 20 28 73 6f 72 74 -tests (sort
ee20: 20 74 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 tests (lambda (
ee30: 61 20 62 29 28 6c 65 74 20 28 28 64 69 72 61 20 a b)(let ((dira
ee40: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
ee50: 64 69 72 20 61 29 29 0a 09 09 09 09 09 09 09 09 dir a)).........
ee60: 09 28 64 69 72 62 20 28 64 62 3a 74 65 73 74 2d .(dirb (db:test-
ee70: 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 29 0a get-rundir b))).
ee80: 09 09 09 09 09 09 09 09 20 20 20 20 28 69 66 20 ........ (if
ee90: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 69 (and (string? di
eea0: 72 61 29 28 73 74 72 69 6e 67 3f 20 64 69 72 62 ra)(string? dirb
eeb0: 29 29 0a 09 09 09 09 09 09 09 09 09 28 3e 20 28 ))..........(> (
eec0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 string-length di
eed0: 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 ra)(string-lengt
eee0: 68 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 09 h dirb))........
eef0: 09 09 23 66 29 29 29 29 29 0a 09 09 20 20 20 20 ..#f)))))...
ef00: 20 20 20 28 74 65 73 74 2d 72 65 74 72 79 2d 74 (test-retry-t
ef10: 69 6d 65 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d ime (make-hash-
ef20: 74 61 62 6c 65 29 29 0a 09 09 20 20 20 20 20 20 table))...
ef30: 20 28 61 6c 6c 6f 77 2d 72 75 6e 2d 74 69 6d 65 (allow-run-time
ef40: 20 20 20 31 30 29 29 20 3b 3b 20 73 65 63 6f 6e 10)) ;; secon
ef50: 64 73 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 ds to allow for
ef60: 6b 69 6c 6c 69 6e 67 20 74 65 73 74 73 20 62 65 killing tests be
ef70: 66 6f 72 65 20 6a 75 73 74 20 62 72 75 74 61 6c fore just brutal
ef80: 6c 79 20 6b 69 6c 6c 69 6e 67 20 27 65 6d 0a 09 ly killing 'em..
ef90: 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 . (let loop ((
efa0: 74 65 73 74 20 28 63 61 72 20 73 6f 72 74 65 64 test (car sorted
efb0: 2d 74 65 73 74 73 29 29 0a 09 09 09 20 20 20 20 -tests))....
efc0: 20 20 28 74 61 6c 20 20 28 63 64 72 20 73 6f 72 (tal (cdr sor
efd0: 74 65 64 2d 74 65 73 74 73 29 29 29 0a 09 09 20 ted-tests)))...
efe0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
eff0: 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a 74 65 -id (db:te
f000: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 st-get-id test))
f010: 0a 09 09 09 20 20 20 20 28 6e 65 77 2d 74 65 73 .... (new-tes
f020: 74 2d 64 61 74 20 20 28 63 64 62 3a 67 65 74 2d t-dat (cdb:get-
f030: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
f040: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 *runremote* test
f050: 2d 69 64 29 29 29 0a 09 09 20 20 20 20 20 20 20 -id)))...
f060: 28 69 66 20 28 6e 6f 74 20 6e 65 77 2d 74 65 73 (if (not new-tes
f070: 74 2d 64 61 74 29 0a 09 09 09 20 20 20 28 62 65 t-dat).... (be
f080: 67 69 6e 0a 09 09 09 20 20 20 20 20 28 64 65 62 gin.... (deb
f090: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
f0a0: 52 3a 20 57 65 20 68 61 76 65 20 61 20 74 65 73 R: We have a tes
f0b0: 74 2d 69 64 20 6f 66 20 22 20 74 65 73 74 2d 69 t-id of " test-i
f0c0: 64 20 22 20 62 75 74 20 6e 6f 20 72 65 63 6f 72 d " but no recor
f0d0: 64 20 77 61 73 20 66 6f 75 6e 64 2e 20 4e 4f 54 d was found. NOT
f0e0: 45 3a 20 4e 6f 20 6c 6f 63 6b 69 6e 67 20 6f 66 E: No locking of
f0f0: 20 72 65 63 6f 72 64 73 20 69 73 20 64 6f 6e 65 records is done
f100: 20 62 65 74 77 65 65 6e 20 70 72 6f 63 65 73 73 between process
f110: 65 73 2c 20 64 6f 20 6e 6f 74 20 73 69 6d 75 6c es, do not simul
f120: 74 61 6e 65 6f 75 73 6c 79 20 72 65 6d 6f 76 65 taneously remove
f130: 20 74 68 65 20 73 61 6d 65 20 72 75 6e 20 66 72 the same run fr
f140: 6f 6d 20 74 77 6f 20 70 72 6f 63 65 73 73 65 73 om two processes
f150: 21 22 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 !").... (if
f160: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
f170: 29 0a 09 09 09 09 20 28 6c 6f 6f 70 20 28 63 61 )..... (loop (ca
f180: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
f190: 29 29 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 28 )).... (let* (
f1a0: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 28 (item-path (
f1b0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
f1c0: 2d 70 61 74 68 20 6e 65 77 2d 74 65 73 74 2d 64 -path new-test-d
f1d0: 61 74 29 29 0a 09 09 09 09 20 20 28 74 65 73 74 at))..... (test
f1e0: 2d 6e 61 6d 65 20 20 20 20 20 28 64 62 3a 74 65 -name (db:te
f1f0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
f200: 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 new-test-dat))..
f210: 09 09 09 20 20 28 72 75 6e 2d 64 69 72 20 20 20 ... (run-dir
f220: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
f230: 2d 72 75 6e 64 69 72 20 6e 65 77 2d 74 65 73 74 -rundir new-test
f240: 2d 64 61 74 29 29 20 20 20 20 3b 3b 20 72 75 6e -dat)) ;; run
f250: 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 dir is from the
f260: 20 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 09 20 link tree.....
f270: 20 28 72 65 61 6c 2d 64 69 72 20 20 20 20 20 20 (real-dir
f280: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
f290: 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 ? run-dir)......
f2a0: 09 20 20 20 20 20 28 72 65 73 6f 6c 76 65 2d 70 . (resolve-p
f2b0: 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 athname run-dir)
f2c0: 0a 09 09 09 09 09 09 20 20 20 20 20 23 66 29 29 ....... #f))
f2d0: 0a 09 09 09 09 20 20 28 74 65 73 74 2d 73 74 61 ..... (test-sta
f2e0: 74 65 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 te (db:test-g
f2f0: 65 74 2d 73 74 61 74 65 20 6e 65 77 2d 74 65 73 et-state new-tes
f300: 74 2d 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 t-dat))..... (t
f310: 65 73 74 2d 66 75 6c 6c 6e 20 20 20 20 28 64 62 est-fulln (db
f320: 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 :test-get-fullna
f330: 6d 65 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 me new-test-dat)
f340: 29 29 0a 09 09 09 20 20 20 20 20 28 63 61 73 65 )).... (case
f350: 20 61 63 74 69 6f 6e 0a 09 09 09 20 20 20 20 20 action....
f360: 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 ((remove-runs)
f370: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
f380: 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 3a 20 t-info 0 "test:
f390: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 74 " test-name " it
f3a0: 65 73 74 2d 73 74 61 74 65 3a 20 22 20 74 65 73 est-state: " tes
f3b0: 74 2d 73 74 61 74 65 29 0a 09 09 09 09 28 69 66 t-state).....(if
f3c0: 20 28 6d 65 6d 62 65 72 20 74 65 73 74 2d 73 74 (member test-st
f3d0: 61 74 65 20 28 6c 69 73 74 20 22 52 55 4e 4e 49 ate (list "RUNNI
f3e0: 4e 47 22 20 22 4c 41 55 4e 43 48 45 44 22 20 22 NG" "LAUNCHED" "
f3f0: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 REMOTEHOSTSTART"
f400: 20 22 4b 49 4c 4c 52 45 51 22 29 29 0a 09 09 09 "KILLREQ"))....
f410: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 . (begin.....
f420: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
f430: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
f440: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 74 72 efault test-retr
f450: 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 75 6c 6c y-time test-full
f460: 6e 20 23 66 29 29 0a 09 09 09 09 09 20 20 28 62 n #f))...... (b
f470: 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 3b 3b egin...... ;;
f480: 20 77 61 6e 74 20 74 6f 20 73 65 74 20 74 6f 20 want to set to
f490: 52 45 4d 4f 56 49 4e 47 20 42 55 54 20 43 41 4e REMOVING BUT CAN
f4a0: 4e 4f 54 20 64 6f 20 69 74 20 68 65 72 65 3f 0a NOT do it here?.
f4b0: 09 09 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 ..... (hash-t
f4c0: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
f4d0: 65 74 72 79 2d 74 69 6d 65 20 74 65 73 74 2d 66 etry-time test-f
f4e0: 75 6c 6c 6e 20 28 63 75 72 72 65 6e 74 2d 73 65 ulln (current-se
f4f0: 63 6f 6e 64 73 29 29 29 29 0a 09 09 09 09 20 20 conds)))).....
f500: 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 (if (> (- (c
f510: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
f520: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
f530: 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 74 est-retry-time t
f540: 65 73 74 2d 66 75 6c 6c 6e 29 29 20 61 6c 6c 6f est-fulln)) allo
f550: 77 2d 72 75 6e 2d 74 69 6d 65 29 0a 09 09 09 09 w-run-time).....
f560: 09 20 20 3b 3b 20 54 68 69 73 20 74 65 73 74 20 . ;; This test
f570: 69 73 20 6e 6f 74 20 69 6e 20 61 20 63 6f 72 72 is not in a corr
f580: 65 63 74 20 73 74 61 74 65 20 66 6f 72 20 63 6c ect state for cl
f590: 65 61 6e 69 6e 67 20 75 70 2e 20 4c 65 74 27 73 eaning up. Let's
f5a0: 20 74 72 79 20 73 6f 6d 65 20 67 72 61 63 65 66 try some gracef
f5b0: 75 6c 20 73 68 75 74 64 6f 77 6e 20 73 74 65 70 ul shutdown step
f5c0: 73 20 66 69 72 73 74 0a 09 09 09 09 09 20 20 3b s first...... ;
f5d0: 3b 20 53 65 74 20 74 68 65 20 74 65 73 74 20 74 ; Set the test t
f5e0: 6f 20 22 4b 49 4c 4c 52 45 51 22 20 61 6e 64 20 o "KILLREQ" and
f5f0: 77 61 69 74 20 66 69 76 65 20 73 65 63 6f 6e 64 wait five second
f600: 73 20 74 68 65 6e 20 74 72 79 20 61 67 61 69 6e s then try again
f610: 2e 20 52 65 70 65 61 74 20 75 70 20 74 6f 20 66 . Repeat up to f
f620: 69 76 65 20 74 69 6d 65 73 20 74 68 65 6e 20 67 ive times then g
f630: 69 76 65 0a 09 09 09 09 09 20 20 3b 3b 20 75 70 ive...... ;; up
f640: 20 61 6e 64 20 62 6c 6f 77 20 69 74 20 61 77 61 and blow it awa
f650: 79 2e 0a 09 09 09 09 09 20 20 28 62 65 67 69 6e y....... (begin
f660: 0a 09 09 09 09 09 20 20 20 20 28 64 65 62 75 67 ...... (debug
f670: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
f680: 47 3a 20 63 6f 75 6c 64 20 6e 6f 74 20 67 72 61 G: could not gra
f690: 63 65 66 75 6c 6c 79 20 72 65 6d 6f 76 65 20 74 cefully remove t
f6a0: 65 73 74 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e est " test-fulln
f6b0: 20 22 2c 20 74 72 69 65 64 20 74 6f 20 6b 69 6c ", tried to kil
f6c0: 6c 20 69 74 20 74 6f 20 6e 6f 20 61 76 61 69 6c l it to no avail
f6d0: 2e 20 46 6f 72 63 69 6e 67 20 73 74 61 74 65 20 . Forcing state
f6e0: 74 6f 20 46 41 49 4c 45 44 4b 49 4c 4c 20 61 6e to FAILEDKILL an
f6f0: 64 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 09 d continuing")..
f700: 09 09 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 .... (mt:test
f710: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
f720: 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 s-by-id (db:test
f730: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 46 -get-id test) "F
f740: 41 49 4c 45 44 4b 49 4c 4c 22 20 22 6e 2f 61 22 AILEDKILL" "n/a"
f750: 20 23 66 29 0a 09 09 09 09 09 20 20 20 20 28 74 #f)...... (t
f760: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 hread-sleep! 1))
f770: 0a 09 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 ...... (begin..
f780: 09 09 09 09 20 20 20 20 28 6d 74 3a 74 65 73 74 .... (mt:test
f790: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
f7a0: 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 73 74 s-by-id (db:test
f7b0: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 4b -get-id test) "K
f7c0: 49 4c 4c 52 45 51 22 20 22 6e 2f 61 22 20 23 66 ILLREQ" "n/a" #f
f7d0: 29 0a 09 09 09 09 09 20 20 20 20 28 74 68 72 65 )...... (thre
f7e0: 61 64 2d 73 6c 65 65 70 21 20 31 29 29 29 0a 09 ad-sleep! 1)))..
f7f0: 09 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 ... ;; NOTE
f800: 3a 20 54 68 69 73 20 69 73 20 73 75 62 6f 70 74 : This is subopt
f810: 69 6d 61 6c 20 61 73 20 74 68 65 20 74 65 73 74 imal as the test
f820: 64 61 74 61 20 77 69 6c 6c 20 62 65 20 75 73 65 data will be use
f830: 64 20 6c 61 74 65 72 20 61 6e 64 20 74 68 65 20 d later and the
f840: 73 74 61 74 65 2f 73 74 61 74 75 73 20 6d 61 79 state/status may
f850: 20 68 61 76 65 20 63 68 61 6e 67 65 64 20 2e 2e have changed ..
f860: 2e 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 20 ...... (if
f870: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 (null? tal).....
f880: 09 20 20 28 6c 6f 6f 70 20 6e 65 77 2d 74 65 73 . (loop new-tes
f890: 74 2d 64 61 74 20 74 61 6c 29 0a 09 09 09 09 09 t-dat tal)......
f8a0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
f8b0: 29 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 )(append tal (li
f8c0: 73 74 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 st new-test-dat)
f8d0: 29 29 29 29 0a 09 09 09 09 20 20 20 20 28 62 65 ))))..... (be
f8e0: 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 6d gin..... (m
f8f0: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
f900: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 64 -status-by-id (d
f910: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
f920: 73 74 29 20 22 52 45 4d 4f 56 49 4e 47 22 20 22 st) "REMOVING" "
f930: 4c 4f 43 4b 45 44 22 20 23 66 29 0a 09 09 09 09 LOCKED" #f).....
f940: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
f950: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 65 6d nt-info 1 "Attem
f960: 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 pting to remove
f970: 22 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 28 " (if real-dir (
f980: 63 6f 6e 63 20 22 20 64 69 72 20 22 20 72 65 61 conc " dir " rea
f990: 6c 2d 64 69 72 20 22 20 61 6e 64 20 22 29 20 22 l-dir " and ") "
f9a0: 22 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d ") " link " run-
f9b0: 64 69 72 29 0a 09 09 09 09 20 20 20 20 20 20 28 dir)..... (
f9c0: 69 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 69 72 if (and real-dir
f9d0: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 3e ...... (>
f9e0: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
f9f0: 72 65 61 6c 2d 64 69 72 29 20 35 29 0a 09 09 09 real-dir) 5)....
fa00: 09 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 65 .. (file-e
fa10: 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 xists? real-dir)
fa20: 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 ) ;; bad heurist
fa30: 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 ic but should pr
fa40: 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 event /tmp /home
fa50: 20 65 74 63 2e 0a 09 09 09 09 09 20 20 28 62 65 etc....... (be
fa60: 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 gin ;; let* ((re
fa70: 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d alpath (resolve-
fa80: 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 pathname run-dir
fa90: 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 64 65 )))...... (de
faa0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
fab0: 20 22 52 65 63 75 72 73 69 76 65 6c 79 20 72 65 "Recursively re
fac0: 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 moving " real-di
fad0: 72 29 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 r)...... (if
fae0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 (file-exists? re
faf0: 61 6c 2d 64 69 72 29 0a 09 09 09 09 09 09 28 72 al-dir).......(r
fb00: 75 6e 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d uns:safe-delete-
fb10: 74 65 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 test-dir real-di
fb20: 72 29 0a 09 09 09 09 09 09 28 64 65 62 75 67 3a r).......(debug:
fb30: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
fb40: 3a 20 74 65 73 74 20 64 69 72 20 22 20 72 65 61 : test dir " rea
fb50: 6c 2d 64 69 72 20 22 20 61 70 70 65 61 72 73 20 l-dir " appears
fb60: 74 6f 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 to not exist or
fb70: 69 73 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 is not readable"
fb80: 29 29 29 0a 09 09 09 09 09 20 20 28 69 66 20 72 )))...... (if r
fb90: 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 09 20 20 eal-dir ......
fba0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
fbb0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 0 "WARNING: dir
fbc0: 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 ectory " real-di
fbd0: 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 r " does not exi
fbe0: 73 74 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 st")......
fbf0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
fc00: 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 61 6c WARNING: no real
fc10: 20 64 69 72 65 63 74 6f 72 79 20 63 6f 72 72 6f directory corro
fc20: 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 6e 6b sponding to link
fc30: 20 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 6e 6f " run-dir ", no
fc40: 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 29 0a 09 thing done")))..
fc50: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 73 79 ... (if (sy
fc60: 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e mbolic-link? run
fc70: 2d 64 69 72 29 0a 09 09 09 09 09 20 20 28 62 65 -dir)...... (be
fc80: 67 69 6e 0a 09 09 09 09 09 20 20 20 20 28 64 65 gin...... (de
fc90: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
fca0: 20 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 "Removing symli
fcb0: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 nk " run-dir)...
fcc0: 09 09 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ... (handle-e
fcd0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 xceptions......
fce0: 20 20 20 20 65 78 6e 0a 09 09 09 09 09 20 20 20 exn......
fcf0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
fd00: 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
fd10: 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 to remove symli
fd20: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 nk " run-dir ((c
fd30: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
fd40: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
fd50: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 'message) exn) "
fd60: 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 , attempting to
fd70: 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 09 09 09 continue")......
fd80: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c (delete-fil
fd90: 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 e run-dir)))....
fda0: 09 09 20 20 28 69 66 20 28 64 69 72 65 63 74 6f .. (if (directo
fdb0: 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 ry? run-dir)....
fdc0: 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 .. (if (> (
fdd0: 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 directory-fold (
fde0: 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b 20 31 lambda (f x)(+ 1
fdf0: 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 29 20 x)) 0 run-dir)
fe00: 30 29 0a 09 09 09 09 09 09 20 20 28 64 65 62 75 0)....... (debu
fe10: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
fe20: 4e 47 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 NG: refusing to
fe30: 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 remove " run-dir
fe40: 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 " as it is not
fe50: 65 6d 70 74 79 22 29 0a 09 09 09 09 09 09 20 20 empty").......
fe60: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
fe70: 6e 73 0a 09 09 09 09 09 09 20 20 20 65 78 6e 0a ns....... exn.
fe80: 09 09 09 09 09 09 20 20 20 28 64 65 62 75 67 3a ...... (debug:
fe90: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
fea0: 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 Failed to remov
feb0: 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 75 e directory " ru
fec0: 6e 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f n-dir ((conditio
fed0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
fee0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
fef0: 65 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d e) exn) ", attem
ff00: 70 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 pting to continu
ff10: 65 22 29 0a 09 09 09 09 09 09 20 20 20 28 64 65 e")....... (de
ff20: 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 lete-directory r
ff30: 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 09 09 20 un-dir)))......
ff40: 20 20 20 20 20 28 69 66 20 72 75 6e 2d 64 69 72 (if run-dir
ff50: 0a 09 09 09 09 09 09 20 20 28 64 65 62 75 67 3a ....... (debug:
ff60: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
ff70: 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 : not removing "
ff80: 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 run-dir " as it
ff90: 20 65 69 74 68 65 72 20 64 6f 65 73 6e 27 74 20 either doesn't
ffa0: 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 exist or is not
ffb0: 61 20 73 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 a symlink").....
ffc0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
ffd0: 20 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 0 "NOTE: the ru
ffe0: 6e 20 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 n dir for this t
fff0: 65 73 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 est is undefined
10000 2e 20 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 . Test may have
10010 61 6c 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c already been del
10020 65 74 65 64 2e 22 29 29 0a 09 09 09 09 09 20 20 eted."))......
10030 20 20 20 20 29 29 0a 09 09 09 09 20 20 20 20 20 )).....
10040 20 3b 3b 20 4f 6e 6c 79 20 64 65 6c 65 74 65 20 ;; Only delete
10050 74 68 65 20 72 65 63 6f 72 64 73 20 2a 61 66 74 the records *aft
10060 65 72 2a 20 72 65 6d 6f 76 69 6e 67 20 74 68 65 er* removing the
10070 20 64 69 72 65 63 74 6f 72 79 2e 20 49 66 20 74 directory. If t
10080 68 69 6e 67 73 20 66 61 69 6c 20 77 65 20 68 61 hings fail we ha
10090 76 65 20 61 20 72 65 63 6f 72 64 20 0a 09 09 09 ve a record ....
100a0 09 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f . (cdb:remo
100b0 74 65 2d 72 75 6e 20 64 62 3a 64 65 6c 65 74 65 te-run db:delete
100c0 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
100d0 20 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 #f (db:test-get
100e0 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 09 20 -id test)).....
100f0 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n
10100 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 09 ull? tal))......
10110 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
10120 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a )(cdr tal)))))).
10130 09 09 09 20 20 20 20 20 20 20 28 28 73 65 74 2d ... ((set-
10140 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 state-status)...
10150 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
10160 6e 66 6f 20 32 20 22 6e 65 77 20 73 74 61 74 65 nfo 2 "new state
10170 20 22 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 " (car state-st
10180 61 74 75 73 29 20 22 2c 20 6e 65 77 20 73 74 61 atus) ", new sta
10190 74 75 73 20 22 20 28 63 61 64 72 20 73 74 61 74 tus " (cadr stat
101a0 65 2d 73 74 61 74 75 73 29 29 0a 09 09 09 09 28 e-status)).....(
101b0 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
101c0 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 28 e-status-by-id (
101d0 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
101e0 65 73 74 29 20 28 63 61 72 20 73 74 61 74 65 2d est) (car state-
101f0 73 74 61 74 75 73 29 28 63 61 64 72 20 73 74 61 status)(cadr sta
10200 74 65 2d 73 74 61 74 75 73 29 20 23 66 29 0a 09 te-status) #f)..
10210 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c ...(if (not (nul
10220 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 20 20 l? tal)).....
10230 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
10240 28 63 64 72 20 74 61 6c 29 29 29 29 0a 09 09 09 (cdr tal))))....
10250 20 20 20 20 20 20 20 28 28 72 75 6e 2d 77 61 69 ((run-wai
10260 74 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 t).....(debug:pr
10270 69 6e 74 2d 69 6e 66 6f 20 32 20 22 73 74 69 6c int-info 2 "stil
10280 6c 20 77 61 69 74 69 6e 67 2c 20 22 20 28 6c 65 l waiting, " (le
10290 6e 67 74 68 20 74 65 73 74 73 29 20 22 20 74 65 ngth tests) " te
102a0 73 74 73 20 73 74 69 6c 6c 20 72 75 6e 6e 69 6e sts still runnin
102b0 67 22 29 0a 09 09 09 09 28 74 68 72 65 61 64 2d g").....(thread-
102c0 73 6c 65 65 70 21 20 31 30 29 0a 09 09 09 09 28 sleep! 10).....(
102d0 6c 65 74 20 28 28 6e 65 77 2d 74 65 73 74 73 20 let ((new-tests
102e0 28 70 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 (proc-get-tests
102f0 72 75 6e 2d 69 64 29 29 29 0a 09 09 09 09 20 20 run-id))).....
10300 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 2d 74 (if (null? new-t
10310 65 73 74 73 29 0a 09 09 09 09 20 20 20 20 20 20 ests).....
10320 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
10330 6f 20 31 20 22 52 75 6e 20 63 6f 6d 70 6c 65 74 o 1 "Run complet
10340 65 64 20 61 63 63 6f 72 64 69 6e 67 20 74 6f 20 ed according to
10350 7a 65 72 6f 20 74 65 73 74 73 20 6d 61 74 63 68 zero tests match
10360 69 6e 67 20 70 72 6f 76 69 64 65 64 20 63 72 69 ing provided cri
10370 74 65 72 69 61 2e 22 29 0a 09 09 09 09 20 20 20 teria.").....
10380 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
10390 77 2d 74 65 73 74 73 29 28 63 64 72 20 6e 65 77 w-tests)(cdr new
103a0 2d 74 65 73 74 73 29 29 29 29 29 29 29 29 0a 09 -tests))))))))..
103b0 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 20 . )))))..
103c0 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 ;; remove the
103d0 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 74 run if zero test
103e0 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 s remain.. (if
103f0 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 (eq? action 're
10400 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 move-runs)..
10410 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 (let ((remtes
10420 74 73 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 ts (mt:get-tests
10430 2d 66 6f 72 2d 72 75 6e 20 28 64 62 3a 67 65 74 -for-run (db:get
10440 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
10450 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
10460 29 20 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 ) #f '("DELETED"
10470 29 20 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 ) '("n/a") not-i
10480 6e 3a 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 n: #t)))... (if
10490 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
104a0 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 ;; no more test
104b0 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 s remaining...
104c0 20 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 (let* ((dpart
104d0 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 s (string-split
104e0 20 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 lasttpath "/"))
104f0 0a 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 .... (runpath
10500 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
10510 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
10520 09 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 ......(take dpar
10530 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 ts (- (length dp
10540 61 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 arts) 1)).......
10550 22 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 "/"))))...
10560 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
10570 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 "Removing run: "
10580 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a runkey " " (db:
10590 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
105a0 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
105b0 72 75 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 runname") " and
105c0 72 65 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 related record")
105d0 0a 09 09 20 20 20 20 20 20 20 28 63 64 62 3a 72 ... (cdb:r
105e0 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 64 65 6c emote-run db:del
105f0 65 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 ete-run db run-i
10600 64 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 d)... ;; T
10610 68 69 73 20 69 73 20 61 20 70 72 65 74 74 79 20 his is a pretty
10620 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 good place to pu
10630 72 67 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 rge old DELETED
10640 74 65 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 tests... (
10650 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
10660 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 b:delete-tests-f
10670 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 or-run db run-id
10680 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 62 3a )... (cdb:
10690 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 64 65 remote-run db:de
106a0 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 lete-old-deleted
106b0 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
106c0 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 62 3a )... (cdb:
106d0 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 73 65 remote-run db:se
106e0 74 2d 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 t-var db "DELETE
106f0 44 5f 54 45 53 54 53 22 20 28 63 75 72 72 65 6e D_TESTS" (curren
10700 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 t-seconds))...
10710 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 ;; need to
10720 66 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 figure out the p
10730 61 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 ath to the run d
10740 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 ir and remove it
10750 20 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 if empty...
10760 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 ;; (if (nu
10770 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 ll? (glob (conc
10780 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a runpath "/*"))).
10790 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 .. ;;
107a0 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
107b0 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 ;; . (debug:p
107c0 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 rint 1 "Removing
107d0 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 run dir " runpa
107e0 74 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 th)... ;;
107f0 09 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 . (system (conc
10800 22 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 "rmdir -p " runp
10810 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 ath))))...
10820 20 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 ))))).. )).
10830 20 72 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b runs)). #t)..;
10840 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
10850 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10870 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10880 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 =======.;; Routi
10890 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 nes for manipula
108a0 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d ting runs.;;====
108b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
108c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
108d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
108e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
108f0 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e ==..;; Since man
10900 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e y calls to a run
10910 20 72 65 71 75 69 72 65 20 70 72 65 74 74 79 20 require pretty
10920 6d 75 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 much the same se
10930 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 tup .;; this wra
10940 70 70 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 pper is used to
10950 72 65 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 reduce the repli
10960 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 cation of code.(
10970 64 65 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d define (general-
10980 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e run-call switchn
10990 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 ame action-desc
109a0 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 proc). (let ((r
109b0 75 6e 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 unname (args:get
109c0 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 -arg ":runname")
109d0 29 0a 09 28 74 61 72 67 65 74 20 20 28 69 66 20 )..(target (if
109e0 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
109f0 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 target")...
10a00 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
10a10 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 target")...
10a20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
10a30 72 65 71 74 61 72 67 22 29 29 29 29 0a 09 3b 3b reqtarg"))))..;;
10a40 20 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 (th1 #f)).
10a50 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
10a60 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 not target).
10a70 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
10a80 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 "ERROR: Missing
10a90 20 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 required parame
10aa0 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 ter for " switch
10ab0 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 name ", you must
10ac0 20 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 specify the tar
10ad0 67 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 get with -target
10ae0 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 "). (exit 3
10af0 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 )). ((not ru
10b00 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 nname). (de
10b10 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
10b20 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
10b30 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
10b40 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
10b50 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
10b60 69 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 ify the run name
10b70 20 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 with :runname r
10b80 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 unname"). (
10b90 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 exit 3)). (e
10ba0 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 lse. (let (
10bb0 28 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 (db #f).. (
10bc0 6b 65 79 73 20 23 66 29 0a 09 20 20 20 20 28 74 keys #f).. (t
10bd0 61 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a arget (or (args:
10be0 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
10bf0 67 22 29 0a 09 09 09 28 61 72 67 73 3a 67 65 74 g")....(args:get
10c00 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 -arg "-target"))
10c10 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 ))..(if (not (se
10c20 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 tup-for-run))..
10c30 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
10c40 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
10c50 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 "Failed to setu
10c60 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 p, exiting")..
10c70 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
10c80 3b 3b 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 ;; (if (args:get
10c90 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
10ca0 09 3b 3b 20 20 20 20 20 28 63 64 62 3a 72 65 6d .;; (cdb:rem
10cb0 6f 74 65 2d 72 75 6e 20 73 65 72 76 65 72 3a 73 ote-run server:s
10cc0 74 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 65 tart db (args:ge
10cd0 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
10ce0 29 29 0a 09 28 73 65 74 21 20 6b 65 79 73 20 28 ))..(set! keys (
10cf0 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d keys:config-get-
10d00 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 fields *configda
10d10 74 2a 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e t*))..;; have en
10d20 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 ough to process
10d30 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 -target or -reqt
10d40 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 arg here..(if (a
10d50 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
10d60 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 qtarg").. (le
10d70 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 t* ((runconfigf
10d80 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
10d90 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f "/runconfigs.co
10da0 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f nfig")) ;; DO NO
10db0 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a T EVALUATE ALL .
10dc0 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 .. (runconfig
10dd0 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 (read-config ru
10de0 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 74 20 65 nconfigf #f #t e
10df0 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 nviron-patt: #f)
10e00 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 )).. (if (h
10e10 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
10e20 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 fault runconfig
10e30 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
10e40 72 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 reqtarg") #f)...
10e50 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 (keys:target-s
10e60 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 et-args keys (ar
10e70 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
10e80 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d targ") args:arg-
10e90 68 61 73 68 29 0a 09 09 20 20 20 20 0a 09 09 20 hash)... ...
10ea0 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 (begin... (d
10eb0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
10ec0 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 ROR: [" (args:ge
10ed0 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
10ee0 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 ) "] not found i
10ef0 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a n " runconfigf).
10f00 09 09 20 20 20 20 28 69 66 20 64 62 20 28 73 71 .. (if db (sq
10f10 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
10f20 64 62 29 29 0a 09 09 20 20 20 20 28 65 78 69 74 db))... (exit
10f30 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 1)))).. (if
10f40 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
10f50 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 79 73 target")...(keys
10f60 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
10f70 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d keys (args:get-
10f80 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 61 72 arg "-target" ar
10f90 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 72 67 gs:arg-hash) arg
10fa0 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a 09 28 s:arg-hash)))..(
10fb0 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f if (not (car *co
10fc0 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 nfiginfo*))..
10fd0 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
10fe0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
10ff0 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 20 RROR: Attempted
11000 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 to " action-desc
11010 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 61 20 " but run area
11020 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 config file not
11030 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 20 28 found").. (
11040 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 3b 3b exit 1)).. ;;
11050 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 74 75 Extract out stu
11060 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 ff needed in mos
11070 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a t or many calls.
11080 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 68 65 . ;; here the
11090 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 n call proc..
110a0 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 (let* ((keyvals
110b0 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 (keys:target
110c0 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
110d0 72 67 65 74 29 29 29 0a 09 20 20 20 20 20 20 28 rget))).. (
110e0 70 72 6f 63 20 74 61 72 67 65 74 20 72 75 6e 6e proc target runn
110f0 61 6d 65 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 ame keys keyvals
11100 29 29 29 0a 09 28 69 66 20 64 62 20 28 73 71 6c )))..(if db (sql
11110 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
11120 62 29 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 b))..(set! *dids
11130 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 omething* #t))))
11140 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
11150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11160 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11170 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
11190 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 Lock/unlock runs
111a0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
111b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
111c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
111d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
111e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
111f0 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d ne (runs:handle-
11200 6c 6f 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b locking target k
11210 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b eys runname lock
11220 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 unlock user).
11230 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 (let* ((db
11240 20 23 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 #f).. (rundat
11250 20 28 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (mt:get-runs-by
11260 2d 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 -patt keys runna
11270 6d 65 20 74 61 72 67 65 74 29 29 0a 09 20 28 68 me target)).. (h
11280 65 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d eader (vector-
11290 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
112a0 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 (runs (vect
112b0 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
112c0 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
112d0 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
112e0 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 .(let ((run-id (
112f0 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
11300 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
11310 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 r "id")))... (i
11320 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 f (or lock....
11330 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 (and unlock....
11340 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
11350 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 . (print "Do you
11360 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 really wish to
11370 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e unlock run " run
11380 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 -id "?\n y/n:
11390 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 ")..... (equal?
113a0 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 "y" (read-line))
113b0 29 29 29 0a 09 09 20 20 20 20 20 20 28 63 64 62 )))... (cdb
113c0 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 6c :remote-run db:l
113d0 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 ock/unlock-run d
113e0 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e b run-id lock un
113f0 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 lock user)...
11400 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
11410 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 info 0 "Skipping
11420 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 lock/unlock on
11430 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 " run-id))))..
11440 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d runs))).;;==
11450 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11460 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11470 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11480 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11490 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 ====.;; Rollup r
114a0 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
114b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
114c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
114d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
114e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
114f0 20 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 Update the test
11500 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 _meta table for
11510 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e this test.(defin
11520 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 e (runs:update-t
11530 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 est_meta test-na
11540 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 me test-conf).
11550 28 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 (let ((currrecor
11560 64 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 d (cdb:remote-ru
11570 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 n db:testmeta-ge
11580 74 2d 72 65 63 6f 72 64 20 23 66 20 74 65 73 74 t-record #f test
11590 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 -name))). (if
115a0 20 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 (not currrecord
115b0 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 )..(begin.. (se
115c0 74 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d t! currrecord (m
115d0 61 6b 65 2d 76 65 63 74 6f 72 20 31 31 20 23 66 ake-vector 11 #f
115e0 29 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 )).. (cdb:remot
115f0 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 e-run db:testmet
11600 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 a-add-record #f
11610 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
11620 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
11630 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 (lambda (key).
11640 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 (let* ((id
11650 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 x (cadr key))..
11660 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 (fld (car
11670 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 key)).. (va
11680 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 l (config-lookup
11690 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 test-conf "test
116a0 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 _meta" fld)))..
116b0 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
116c0 35 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 5 "idx: " idx "
116d0 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c fld: " fld " val
116e0 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 : " val).. (if (
116f0 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 and val (not (eq
11700 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 ual? (vector-ref
11710 20 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 currrecord idx)
11720 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 val))).. (b
11730 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 egin.. (pr
11740 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 int "Updating "
11750 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c test-name " " fl
11760 64 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 d " to " val)..
11770 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
11780 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 e-run db:testmet
11790 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 a-update-field #
117a0 66 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 f test-name fld
117b0 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 val))))). '(
117c0 28 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 ("author" 2)("ow
117d0 6e 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 ner" 3)("descrip
117e0 74 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 tion" 4)("review
117f0 65 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 ed" 5)("tags" 9)
11800 28 22 6a 6f 62 67 72 6f 75 70 22 20 31 30 29 29 ("jobgroup" 10))
11810 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 )))..;; Update t
11820 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c est_meta for all
11830 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 tests.(define (
11840 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d runs:update-all-
11850 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 test_meta db).
11860 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 (let ((test-name
11870 73 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c s (tests:get-all
11880 29 29 29 20 3b 3b 20 28 74 65 73 74 73 3a 67 65 ))) ;; (tests:ge
11890 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 29 29 29 t-valid-tests)))
118a0 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
118b0 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
118c0 73 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 st-name).
118d0 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 63 6f 6e (let* ((test-con
118e0 66 20 20 20 20 28 6d 74 3a 6c 61 7a 79 2d 72 65 f (mt:lazy-re
118f0 61 64 2d 74 65 73 74 2d 63 6f 6e 66 69 67 20 74 ad-test-config t
11900 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 3b 3b est-name))).. ;;
11910 20 75 73 65 20 74 68 65 20 63 64 62 3a 72 65 6d use the cdb:rem
11920 6f 74 65 2d 72 75 6e 20 69 6e 73 74 65 61 64 20 ote-run instead
11930 6f 66 20 70 61 73 73 69 6e 67 20 69 6e 20 64 62 of passing in db
11940 0a 09 20 28 69 66 20 74 65 73 74 2d 63 6f 6e 66 .. (if test-conf
11950 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
11960 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d st_meta test-nam
11970 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 29 0a e test-conf)))).
11980 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
11990 2d 6b 65 79 73 20 74 65 73 74 2d 6e 61 6d 65 73 -keys test-names
119a0 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 6f ))))..;; This co
119b0 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 20 uld probably be
119c0 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f 20 refactored into
119d0 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 72 one complex quer
119e0 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 72 y ....(define (r
119f0 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b uns:rollup-run k
11a00 65 79 73 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 eys runname user
11a10 20 6b 65 79 76 61 6c 73 29 0a 20 20 28 64 65 62 keyvals). (deb
11a20 75 67 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 ug:print 4 "runs
11a30 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 :rollup-run, key
11a40 73 3a 20 22 20 6b 65 79 73 20 22 20 3a 72 75 6e s: " keys " :run
11a50 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 name " runname "
11a60 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 user: " user).
11a70 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
11a80 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 #f).. (
11a90 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 new-run-id
11aa0 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
11ab0 64 62 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 db:register-run
11ac0 23 66 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 #f keyvals runna
11ad0 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 me "new" "n/a" u
11ae0 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 65 ser)).. (prev-te
11af0 73 74 73 20 20 20 20 20 20 28 63 64 62 3a 72 65 sts (cdb:re
11b00 6d 6f 74 65 2d 72 75 6e 20 74 65 73 74 3a 67 65 mote-run test:ge
11b10 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 t-matching-previ
11b20 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
11b30 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d ords db new-run-
11b40 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 28 id "%" "%")).. (
11b50 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 20 curr-tests
11b60 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f (mt:get-tests-fo
11b70 72 2d 72 75 6e 20 6e 65 77 2d 72 75 6e 2d 69 64 r-run new-run-id
11b80 20 22 25 2f 25 22 20 27 28 29 20 27 28 29 29 29 "%/%" '() '()))
11b90 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 .. (curr-tests-h
11ba0 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ash (make-hash-t
11bb0 61 62 6c 65 29 29 29 0a 20 20 20 20 28 63 64 62 able))). (cdb
11bc0 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 75 :remote-run db:u
11bd0 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f pdate-run-event_
11be0 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d time db new-run-
11bf0 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 id). ;; index
11c00 20 74 68 65 20 61 6c 72 65 61 64 79 20 73 61 76 the already sav
11c10 65 64 20 74 65 73 74 73 20 62 79 20 74 65 73 74 ed tests by test
11c20 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d 64 61 74 name and itemdat
11c30 20 69 6e 20 63 75 72 72 2d 74 65 73 74 73 2d 68 in curr-tests-h
11c40 61 73 68 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ash. (for-eac
11c50 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
11c60 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
11c70 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
11c80 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 (db:test-get-t
11c90 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
11ca0 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
11cb0 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
11cc0 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 -item-path testd
11cd0 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c at)).. (ful
11ce0 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 l-name (conc tes
11cf0 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
11d00 61 74 68 29 29 29 0a 09 20 28 68 61 73 68 2d 74 ath))).. (hash-t
11d10 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 able-set! curr-t
11d20 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e ests-hash full-n
11d30 61 6d 65 20 74 65 73 74 64 61 74 29 29 29 0a 20 ame testdat))).
11d40 20 20 20 20 63 75 72 72 2d 74 65 73 74 73 29 0a curr-tests).
11d50 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e ;; NOPE: Non
11d60 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 -optimal approac
11d70 68 2e 20 54 72 79 20 74 68 69 73 20 69 6e 73 74 h. Try this inst
11d80 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e ead.. ;; 1.
11d90 20 74 65 73 74 73 20 61 72 65 20 72 65 63 65 69 tests are recei
11da0 76 65 64 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d ved in a list, m
11db0 6f 73 74 20 72 65 63 65 6e 74 20 66 69 72 73 74 ost recent first
11dc0 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 . ;; 2. rep
11dd0 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 lace the rollup
11de0 74 65 73 74 20 77 69 74 68 20 74 68 65 20 6e 65 test with the ne
11df0 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 w *always*. (
11e00 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
11e10 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
11e20 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
11e30 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 testname (db:te
11e40 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
11e50 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
11e60 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
11e70 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
11e80 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 th testdat))..
11e90 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
11ea0 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
11eb0 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 " item-path))..
11ec0 20 20 20 20 20 28 70 72 65 76 2d 74 65 73 74 2d (prev-test-
11ed0 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d dat (hash-table-
11ee0 72 65 66 2f 64 65 66 61 75 6c 74 20 63 75 72 72 ref/default curr
11ef0 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c -tests-hash full
11f00 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 -name #f))..
11f10 20 20 28 74 65 73 74 2d 73 74 65 70 73 20 20 20 (test-steps
11f20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
11f30 20 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f db:get-steps-fo
11f40 72 2d 74 65 73 74 20 64 62 20 28 64 62 3a 74 65 r-test db (db:te
11f50 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
11f60 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e 65 77 t))).. (new
11f70 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 -test-record #f)
11f80 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 ).. ;; replace t
11f90 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 74 hese with insert
11fa0 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 61 ... select.. (a
11fb0 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 pply sqlite3:exe
11fc0 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 63 cute ...db ...(c
11fd0 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
11fe0 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
11ff0 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 s (run_id,testna
12000 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
12010 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 2c event_time,host,
12020 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 65 cpuload,diskfree
12030 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 74 ,uname,rundir,it
12040 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 61 em_path,run_dura
12050 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c tion,final_logf,
12060 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 comment) "...
12070 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f 2c "VALUES (?,?,
12080 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
12090 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e 65 ?,?,?,?);")...ne
120a0 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 28 w-run-id (cddr (
120b0 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 73 vector->list tes
120c0 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 20 tdat))).. (set!
120d0 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 72 new-testdat (car
120e0 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (mt:get-tests-f
120f0 6f 72 2d 72 75 6e 20 6e 65 77 2d 72 75 6e 2d 69 or-run new-run-i
12100 64 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 d (conc testname
12110 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 20 "/" item-path)
12120 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 68 61 '() '()))).. (ha
12130 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 sh-table-set! cu
12140 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
12150 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 ll-name new-test
12160 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 6f 75 dat) ;; this cou
12170 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e 67 2c ld be confusing,
12180 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 73 68 which record sh
12190 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 68 65 ould go into the
121a0 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f 0a 09 lookup table?..
121b0 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 ;; Now duplicat
121c0 65 20 74 68 65 20 74 65 73 74 20 73 74 65 70 73 e the test steps
121d0 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
121e0 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 4 "Copying recor
121f0 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 70 73 ds in test_steps
12200 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 from test_id="
12210 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
12220 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 testdat) " to "
12230 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
12240 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 new-testdat))..
12250 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
12260 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 .. (lambda ()..
12270 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 (sqlite3:exe
12280 63 75 74 65 20 0a 09 20 20 20 20 20 64 62 20 0a cute .. db .
12290 09 20 20 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 . (conc "INS
122a0 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
122b0 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 73 20 28 NTO test_steps (
122c0 74 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 6d 65 test_id,stepname
122d0 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 ,state,status,ev
122e0 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 ent_time,comment
122f0 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 ) "... "SELECT
12300 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
12310 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 id new-testdat)
12320 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 ",stepname,state
12330 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
12340 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 me,comment FROM
12350 74 65 73 74 5f 73 74 65 70 73 20 57 48 45 52 45 test_steps WHERE
12360 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 test_id=?;")..
12370 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
12380 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 20 -id testdat))..
12390 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 ;; Now duplic
123a0 61 74 65 20 74 68 65 20 74 65 73 74 20 64 61 74 ate the test dat
123b0 61 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 a.. (debug:pr
123c0 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 int 4 "Copying r
123d0 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 64 ecords in test_d
123e0 61 74 61 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 ata from test_id
123f0 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d =" (db:test-get-
12400 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f id testdat) " to
12410 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
12420 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 id new-testdat))
12430 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 .. (sqlite3:e
12440 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 62 xecute .. db
12450 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 49 .. (conc "I
12460 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
12470 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 61 20 INTO test_data
12480 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 6f 72 (test_id,categor
12490 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 y,variable,value
124a0 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e ,expected,tol,un
124b0 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 its,comment) "..
124c0 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 28 64 . "SELECT " (d
124d0 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 b:test-get-id ne
124e0 77 2d 74 65 73 74 64 61 74 29 20 22 2c 63 61 74 w-testdat) ",cat
124f0 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 egory,variable,v
12500 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f alue,expected,to
12510 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 l,units,comment
12520 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 20 57 FROM test_data W
12530 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 HERE test_id=?;"
12540 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 ).. (db:test
12550 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
12560 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 70 72 ))).. )). pr
12570 65 76 2d 74 65 73 74 73 29 29 29 0a 09 20 0a 20 ev-tests))).. .
12580 20 20 20 20 0a .