0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 28 64 uses server)).(d
02b0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 29 eclare (uses mt)
02c0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
02d0: 20 61 72 63 68 69 76 65 29 29 0a 3b 3b 20 28 64 archive)).;; (d
02e0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 66 69 6c eclare (uses fil
02f0: 65 64 62 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 edb))..(include
0300: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0310: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0320: 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 key_records.scm"
0330: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0340: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0350: 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 clude "run_recor
0360: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0370: 65 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e e "test_records.
0380: 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 scm")..(define (
0390: 72 75 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 runs:test-get-fu
03a0: 6c 6c 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 ll-path test).
03b0: 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
03c0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
03d0: 73 74 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a stname test)).
03e0: 09 20 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a . (itempath (db:
03f0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
0400: 74 68 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 th test))). (
0410: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 conc testname (i
0420: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 f (equal? itempa
0430: 74 68 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 th "") "" (conc
0440: 22 28 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 "(" itempath ")"
0450: 29 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 20 3b 3b )))))..;;;;;; ;;
0460: 20 54 68 69 73 20 69 73 20 74 68 65 20 2a 6e 65 This is the *ne
0470: 77 2a 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 w* methodology.
0480: 4f 6e 65 20 72 65 63 6f 72 64 20 74 6f 20 69 6e One record to in
0490: 66 6f 72 6d 20 74 68 65 6d 20 61 6e 64 20 69 6e form them and in
04a0: 20 74 68 65 20 63 68 61 6f 73 2c 20 6f 72 67 61 the chaos, orga
04b0: 6e 69 73 65 20 74 68 65 6d 2e 0a 3b 3b 3b 3b 3b nise them..;;;;;
04c0: 3b 20 3b 3b 0a 3b 3b 3b 3b 3b 3b 20 28 64 65 66 ; ;;.;;;;;; (def
04d0: 69 6e 65 20 28 72 75 6e 73 3a 63 72 65 61 74 65 ine (runs:create
04e0: 2d 72 75 6e 2d 72 65 63 6f 72 64 20 61 72 65 61 -run-record area
04f0: 2d 64 61 74 29 20 3b 3b 20 23 21 6b 65 79 20 28 -dat) ;; #!key (
0500: 72 65 6d 6f 74 65 20 23 66 29 29 0a 3b 3b 3b 3b remote #f)).;;;;
0510: 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 72 65 6d ;; (let* ((rem
0520: 6f 74 65 20 20 20 20 20 20 20 28 6d 65 67 61 74 ote (megat
0530: 65 73 74 3a 61 72 65 61 2d 72 65 6d 6f 74 65 20 est:area-remote
0540: 20 20 20 61 72 65 61 2d 64 61 74 29 29 0a 3b 3b area-dat)).;;
0550: 3b 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 28 63 ;;;; (c
0560: 6f 6e 66 69 67 64 61 74 20 20 20 20 28 6d 65 67 onfigdat (meg
0570: 61 74 65 73 74 3a 61 72 65 61 2d 63 6f 6e 66 69 atest:area-confi
0580: 67 64 61 74 20 61 72 65 61 2d 64 61 74 29 29 0a gdat area-dat)).
0590: 3b 3b 3b 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;;;;;
05a0: 28 74 6f 70 70 61 74 68 20 20 20 20 20 20 28 6d (toppath (m
05b0: 65 67 61 74 65 73 74 3a 61 72 65 61 2d 70 61 74 egatest:area-pat
05c0: 68 20 20 20 20 20 20 61 72 65 61 2d 64 61 74 29 h area-dat)
05d0: 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 20 28 6d 63 6f )).;;;;;; . (mco
05e0: 6e 66 69 67 20 20 20 20 20 20 28 69 66 20 63 6f nfig (if co
05f0: 6e 66 69 67 64 61 74 0a 3b 3b 3b 3b 3b 3b 20 09 nfigdat.;;;;;; .
0600: 09 20 20 20 20 20 20 20 20 20 20 20 63 6f 6e 66 . conf
0610: 69 67 64 61 74 0a 3b 3b 3b 3b 3b 3b 20 09 09 20 igdat.;;;;;; ..
0620: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6c (if (l
0630: 61 75 6e 63 68 3a 73 65 74 75 70 2d 66 6f 72 2d aunch:setup-for-
0640: 72 75 6e 29 0a 3b 3b 3b 3b 3b 3b 20 09 09 20 20 run).;;;;;; ..
0650: 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6e con
0660: 66 69 67 64 61 74 0a 3b 3b 3b 3b 3b 3b 20 09 09 figdat.;;;;;; ..
0670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0680: 62 65 67 69 6e 0a 3b 3b 3b 3b 3b 3b 20 09 09 20 begin.;;;;;; ..
0690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
06b0: 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 ERROR: Called se
06c0: 74 75 70 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 tup in a non-meg
06d0: 61 74 65 73 74 20 61 72 65 61 2c 20 65 78 69 74 atest area, exit
06e0: 69 6e 67 22 29 0a 3b 3b 3b 3b 3b 3b 20 09 09 20 ing").;;;;;; ..
06f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0700: 28 65 78 69 74 20 31 29 29 29 29 29 0a 3b 3b 3b (exit 1))))).;;;
0710: 3b 3b 3b 20 09 20 20 28 72 75 6e 72 65 63 20 20 ;;; . (runrec
0720: 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 65 63 (runs:runrec
0730: 2d 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 0a 3b -make-record)).;
0740: 3b 3b 3b 3b 3b 20 09 20 20 28 74 61 72 67 65 74 ;;;;; . (target
0750: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 61 72 (common:ar
0760: 67 73 2d 67 65 74 2d 74 61 72 67 65 74 29 29 0a gs-get-target)).
0770: 3b 3b 3b 3b 3b 3b 20 09 20 20 28 72 75 6e 6e 61 ;;;;;; . (runna
0780: 6d 65 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 me (or (args
0790: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 :get-arg "-runna
07a0: 6d 65 22 29 0a 3b 3b 3b 3b 3b 3b 20 09 09 20 20 me").;;;;;; ..
07b0: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 (args:g
07c0: 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
07d0: 22 29 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 20 20 28 "))).;;;;;; . (
07e0: 74 65 73 74 70 61 74 74 20 20 20 20 28 6f 72 20 testpatt (or
07f0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
0800: 74 65 73 74 70 61 74 74 22 29 0a 3b 3b 3b 3b 3b testpatt").;;;;;
0810: 3b 20 09 09 20 20 20 20 20 20 20 20 20 20 20 28 ; .. (
0820: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
0830: 75 6e 74 65 73 74 73 22 29 29 29 0a 3b 3b 3b 3b untests"))).;;;;
0840: 3b 3b 20 09 20 20 28 6b 65 79 73 20 20 20 20 20 ;; . (keys
0850: 20 20 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d (keys:config-
0860: 67 65 74 2d 66 69 65 6c 64 73 20 6d 63 6f 6e 66 get-fields mconf
0870: 69 67 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 20 20 28 ig)).;;;;;; . (
0880: 6b 65 79 76 61 6c 73 20 20 20 20 20 28 6b 65 79 keyvals (key
0890: 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c s:target->keyval
08a0: 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 3b keys target)).;
08b0: 3b 3b 3b 3b 3b 20 09 20 20 28 65 6e 76 64 61 74 ;;;;; . (envdat
08c0: 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 20 3b keyvals) ;
08d0: 3b 20 69 6e 69 74 69 61 6c 20 76 61 6c 75 65 73 ; initial values
08e0: 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 76 start with keyv
08f0: 61 6c 73 0a 3b 3b 3b 3b 3b 3b 20 09 20 20 28 72 als.;;;;;; . (r
0900: 75 6e 63 6f 6e 66 69 67 20 20 20 23 66 29 0a 3b unconfig #f).;
0910: 3b 3b 3b 3b 3b 20 09 20 20 28 74 72 61 6e 73 70 ;;;;; . (transp
0920: 6f 72 74 20 20 20 28 6f 72 20 28 61 72 67 73 3a ort (or (args:
0930: 67 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 get-arg "-transp
0940: 6f 72 74 22 29 20 27 68 74 74 70 29 29 0a 3b 3b ort") 'http)).;;
0950: 3b 3b 3b 3b 20 09 20 20 28 72 75 6e 2d 69 64 20 ;;;; . (run-id
0960: 20 20 20 20 20 23 66 29 29 0a 3b 3b 3b 3b 3b 3b #f)).;;;;;;
0970: 20 20 20 20 20 3b 3b 20 53 65 74 20 61 6c 6c 20 ;; Set all
0980: 74 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 the environment
0990: 76 61 72 73 20 77 65 20 6b 6e 6f 77 20 73 6f 20 vars we know so
09a0: 66 61 72 2c 20 73 74 61 72 74 20 77 69 74 68 20 far, start with
09b0: 6b 65 79 73 0a 3b 3b 3b 3b 3b 3b 20 20 20 20 20 keys.;;;;;;
09c0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
09d0: 61 20 28 6b 65 79 76 61 6c 29 0a 3b 3b 3b 3b 3b a (keyval).;;;;;
09e0: 3b 20 09 09 28 73 65 74 65 6e 76 20 28 63 61 72 ; ..(setenv (car
09f0: 20 6b 65 79 76 61 6c 29 28 63 61 64 72 20 6b 65 keyval)(cadr ke
0a00: 79 76 61 6c 29 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 yval))).;;;;;; .
0a10: 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 0a 3b keyvals).;
0a20: 3b 3b 3b 3b 3b 20 20 20 20 20 3b 3b 20 53 65 74 ;;;;; ;; Set
0a30: 20 75 70 20 76 61 72 69 6f 75 73 20 61 6e 64 20 up various and
0a40: 73 75 6e 64 72 79 20 6b 6e 6f 77 6e 20 76 61 72 sundry known var
0a50: 73 20 68 65 72 65 0a 3b 3b 3b 3b 3b 3b 20 20 20 s here.;;;;;;
0a60: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
0a70: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 74 6f 70 N_AREA_HOME" top
0a80: 70 61 74 68 29 0a 3b 3b 3b 3b 3b 3b 20 20 20 20 path).;;;;;;
0a90: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
0aa0: 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 0a 3b NAME" runname).;
0ab0: 3b 3b 3b 3b 3b 20 20 20 20 20 28 73 65 74 65 6e ;;;;; (seten
0ac0: 76 20 22 4d 54 5f 54 41 52 47 45 54 22 20 20 74 v "MT_TARGET" t
0ad0: 61 72 67 65 74 29 0a 3b 3b 3b 3b 3b 3b 20 20 20 arget).;;;;;;
0ae0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE
0af0: 53 54 53 55 49 54 45 4e 41 4d 45 22 20 28 63 6f STSUITENAME" (co
0b00: 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 mmon:get-testsui
0b10: 74 65 2d 6e 61 6d 65 29 29 0a 3b 3b 3b 3b 3b 3b te-name)).;;;;;;
0b20: 20 20 20 20 20 28 73 65 74 21 20 65 6e 76 64 61 (set! envda
0b30: 74 20 28 61 70 70 65 6e 64 20 0a 3b 3b 3b 3b 3b t (append .;;;;;
0b40: 3b 20 09 09 20 20 65 6e 76 64 61 74 0a 3b 3b 3b ; .. envdat.;;;
0b50: 3b 3b 3b 20 09 09 20 20 28 6c 69 73 74 20 28 6c ;;; .. (list (l
0b60: 69 73 74 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 ist "MT_RUN_AREA
0b70: 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 29 0a _HOME" toppath).
0b80: 3b 3b 3b 3b 3b 3b 20 09 09 09 28 6c 69 73 74 20 ;;;;;; ...(list
0b90: 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 20 "MT_RUNNAME"
0ba0: 20 20 20 72 75 6e 6e 61 6d 65 29 0a 3b 3b 3b 3b runname).;;;;
0bb0: 3b 3b 20 09 09 09 28 6c 69 73 74 20 22 4d 54 5f ;; ...(list "MT_
0bc0: 54 41 52 47 45 54 22 20 20 20 20 20 20 20 20 74 TARGET" t
0bd0: 61 72 67 65 74 29 29 29 29 0a 3b 3b 3b 3b 3b 3b arget)))).;;;;;;
0be0: 20 20 20 20 20 3b 3b 20 4e 6f 77 20 63 61 6e 20 ;; Now can
0bf0: 72 65 61 64 20 74 68 65 20 72 75 6e 63 6f 6e 66 read the runconf
0c00: 69 67 73 20 66 69 6c 65 0a 3b 3b 3b 3b 3b 3b 20 igs file.;;;;;;
0c10: 20 20 20 20 3b 3b 20 0a 3b 3b 3b 3b 3b 3b 20 20 ;; .;;;;;;
0c20: 20 20 20 28 73 65 74 21 20 72 75 6e 63 6f 6e 66 (set! runconf
0c30: 69 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 ig (read-config
0c40: 28 63 6f 6e 63 20 20 74 6f 70 70 61 74 68 20 22 (conc toppath "
0c50: 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
0c60: 69 67 22 29 20 23 66 20 23 74 20 73 65 63 74 69 ig") #f #t secti
0c70: 6f 6e 73 3a 20 28 6c 69 73 74 20 22 64 65 66 61 ons: (list "defa
0c80: 75 6c 74 22 20 74 61 72 67 65 74 29 29 29 0a 3b ult" target))).;
0c90: 3b 3b 3b 3b 3b 20 20 20 20 20 28 69 66 20 28 6e ;;;;; (if (n
0ca0: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
0cb0: 65 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 6f ef/default runco
0cc0: 6e 66 69 67 20 28 61 72 67 73 3a 67 65 74 2d 61 nfig (args:get-a
0cd0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 23 rg "-reqtarg") #
0ce0: 66 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 28 62 65 67 f)).;;;;;; .(beg
0cf0: 69 6e 0a 3b 3b 3b 3b 3b 3b 20 09 20 20 28 64 65 in.;;;;;; . (de
0d00: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
0d10: 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 OR: [" (args:get
0d20: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
0d30: 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e "] not found in
0d40: 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 3b " runconfigf).;
0d50: 3b 3b 3b 3b 3b 20 09 20 20 28 69 66 20 64 62 20 ;;;;; . (if db
0d60: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
0d70: 65 21 20 64 62 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 e! db)).;;;;;; .
0d80: 20 20 28 65 78 69 74 20 31 29 29 29 0a 3b 3b 3b (exit 1))).;;;
0d90: 3b 3b 3b 20 20 20 20 20 3b 3b 20 4e 6f 77 20 68 ;;; ;; Now h
0da0: 61 76 65 20 72 75 6e 63 6f 6e 66 69 67 73 20 64 ave runconfigs d
0db0: 61 74 61 20 6c 6f 61 64 65 64 2c 20 73 65 74 20 ata loaded, set
0dc0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 73 environment vars
0dd0: 0a 3b 3b 3b 3b 3b 3b 20 20 20 20 20 28 66 6f 72 .;;;;;; (for
0de0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 -each (lambda (s
0df0: 65 63 74 69 6f 6e 29 0a 3b 3b 3b 3b 3b 3b 20 09 ection).;;;;;; .
0e00: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
0e10: 64 61 20 28 76 61 72 76 61 6c 29 0a 3b 3b 3b 3b da (varval).;;;;
0e20: 3b 3b 20 09 09 09 20 20 20 20 28 73 65 74 21 20 ;; ... (set!
0e30: 65 6e 76 64 61 74 20 28 61 70 70 65 6e 64 20 65 envdat (append e
0e40: 6e 76 64 61 74 20 28 6c 69 73 74 20 76 61 72 76 nvdat (list varv
0e50: 61 6c 29 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 09 09 al))).;;;;;; ...
0e60: 20 20 20 20 28 73 61 66 65 2d 73 65 74 65 6e 76 (safe-setenv
0e70: 20 28 63 61 72 20 76 61 72 76 61 6c 29 28 63 61 (car varval)(ca
0e80: 64 72 20 76 61 72 76 61 6c 29 29 29 0a 3b 3b 3b dr varval))).;;;
0e90: 3b 3b 3b 20 09 09 09 20 20 28 63 6f 6e 66 69 67 ;;; ... (config
0ea0: 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 72 75 f:get-section ru
0eb0: 6e 63 6f 6e 66 69 67 20 73 65 63 74 69 6f 6e 29 nconfig section)
0ec0: 29 29 0a 3b 3b 3b 3b 3b 3b 20 09 20 20 20 20 20 )).;;;;;; .
0ed0: 20 28 6c 69 73 74 20 22 64 65 66 61 75 6c 74 22 (list "default"
0ee0: 20 74 61 72 67 65 74 29 29 0a 3b 3b 3b 3b 3b 3b target)).;;;;;;
0ef0: 20 20 20 20 20 28 76 65 63 74 6f 72 20 74 61 72 (vector tar
0f00: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
0f10: 70 61 74 74 20 6b 65 79 73 20 6b 65 79 76 61 6c patt keys keyval
0f20: 73 20 65 6e 76 64 61 74 20 6d 63 6f 6e 66 69 67 s envdat mconfig
0f30: 20 72 75 6e 63 6f 6e 66 69 67 20 28 63 6f 6d 6d runconfig (comm
0f40: 6f 6e 3a 67 65 74 2d 72 65 6d 6f 74 65 20 72 65 on:get-remote re
0f50: 6d 6f 74 65 20 72 75 6e 2d 69 64 29 20 74 72 61 mote run-id) tra
0f60: 6e 73 70 6f 72 74 20 64 62 20 74 6f 70 70 61 74 nsport db toppat
0f70: 68 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 h run-id)))..(de
0f80: 66 69 6e 65 20 28 72 75 6e 73 3a 73 65 74 2d 6d fine (runs:set-m
0f90: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
0fa0: 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 run-id area-dat
0fb0: 20 23 21 6b 65 79 20 28 69 6e 6b 65 79 73 20 23 #!key (inkeys #
0fc0: 66 29 28 69 6e 72 75 6e 6e 61 6d 65 20 23 66 29 f)(inrunname #f)
0fd0: 28 69 6e 6b 65 79 76 61 6c 73 20 23 66 29 29 0a (inkeyvals #f)).
0fe0: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 (let* ((config
0ff0: 64 61 74 20 28 6d 65 67 61 74 65 73 74 3a 61 72 dat (megatest:ar
1000: 65 61 2d 63 6f 6e 66 69 67 64 61 74 20 61 72 65 ea-configdat are
1010: 61 2d 64 61 74 29 29 0a 09 20 28 74 6f 70 70 61 a-dat)).. (toppa
1020: 74 68 20 20 20 28 6d 65 67 61 74 65 73 74 3a 61 th (megatest:a
1030: 72 65 61 2d 70 61 74 68 20 20 20 20 20 20 61 72 rea-path ar
1040: 65 61 2d 64 61 74 29 29 0a 09 20 28 74 61 72 67 ea-dat)).. (targ
1050: 65 74 20 20 20 20 28 6f 72 20 28 63 6f 6d 6d 6f et (or (commo
1060: 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 n:args-get-targe
1070: 74 29 0a 09 09 09 28 67 65 74 2d 65 6e 76 69 72 t)....(get-envir
1080: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
1090: 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 "MT_TARGET")))..
10a0: 20 28 6b 65 79 73 20 20 20 20 28 69 66 20 69 6e (keys (if in
10b0: 6b 65 79 73 20 20 20 20 69 6e 6b 65 79 73 20 20 keys inkeys
10c0: 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 20 (rmt:get-keys
10d0: 61 72 65 61 2d 64 61 74 29 29 29 0a 09 20 28 6b area-dat))).. (k
10e0: 65 79 76 61 6c 73 20 20 20 28 69 66 20 69 6e 6b eyvals (if ink
10f0: 65 79 76 61 6c 73 20 69 6e 6b 65 79 76 61 6c 73 eyvals inkeyvals
1100: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b (keys:target->k
1110: 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 eyval keys targe
1120: 74 29 29 29 0a 09 20 28 76 61 6c 73 20 20 20 20 t))).. (vals
1130: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
1140: 66 2f 64 65 66 61 75 6c 74 20 2a 65 6e 76 2d 76 f/default *env-v
1150: 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 ars-by-run-id* r
1160: 75 6e 2d 69 64 20 23 66 29 29 0a 09 20 28 6c 69 un-id #f)).. (li
1170: 6e 6b 2d 74 72 65 65 20 28 63 6f 6e 66 69 67 66 nk-tree (configf
1180: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
1190: 74 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 t "setup" "linkt
11a0: 72 65 65 22 29 29 29 0a 20 20 20 20 3b 3b 20 67 ree"))). ;; g
11b0: 65 74 20 74 68 65 20 69 6e 66 6f 20 66 72 6f 6d et the info from
11c0: 20 74 68 65 20 64 62 20 61 6e 64 20 70 75 74 20 the db and put
11d0: 69 74 20 69 6e 20 74 68 65 20 63 61 63 68 65 0a it in the cache.
11e0: 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d 74 72 65 (if link-tre
11f0: 65 0a 09 28 73 65 74 65 6e 76 20 22 4d 54 5f 4c e..(setenv "MT_L
1200: 49 4e 4b 54 52 45 45 22 20 6c 69 6e 6b 2d 74 72 INKTREE" link-tr
1210: 65 65 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e ee)..(debug:prin
1220: 74 20 30 20 22 45 52 52 4f 52 3a 20 6c 69 6e 6b t 0 "ERROR: link
1230: 74 72 65 65 20 6e 6f 74 20 73 65 74 2c 20 73 68 tree not set, sh
1240: 6f 75 6c 64 20 62 65 20 73 65 74 20 69 6e 20 6d ould be set in m
1250: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 69 egatest.config i
1260: 6e 20 5b 73 65 74 75 70 5d 20 73 65 63 74 69 6f n [setup] sectio
1270: 6e 2e 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e n.")). (if (n
1280: 6f 74 20 76 61 6c 73 29 0a 09 28 6c 65 74 20 28 ot vals)..(let (
1290: 28 68 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (ht (make-hash-t
12a0: 61 62 6c 65 29 29 29 0a 09 20 20 28 68 61 73 68 able))).. (hash
12b0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 65 6e 76 -table-set! *env
12c0: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
12d0: 20 72 75 6e 2d 69 64 20 68 74 29 0a 09 20 20 28 run-id ht).. (
12e0: 73 65 74 21 20 76 61 6c 73 20 68 74 29 0a 09 20 set! vals ht)..
12f0: 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 (for-each.. (
1300: 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 20 20 lambda (key)..
1310: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
1320: 65 74 21 20 76 61 6c 73 20 28 63 61 72 20 6b 65 et! vals (car ke
1330: 79 29 20 28 63 61 64 72 20 6b 65 79 29 29 29 0a y) (cadr key))).
1340: 09 20 20 20 6b 65 79 76 61 6c 73 29 29 29 0a 20 . keyvals))).
1350: 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 20 63 ;; from the c
1360: 61 63 68 65 64 20 64 61 74 61 20 73 65 74 20 74 ached data set t
1370: 68 65 20 76 61 72 73 0a 20 20 20 20 28 68 61 73 he vars. (has
1380: 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 h-table-for-each
1390: 0a 20 20 20 20 20 76 61 6c 73 0a 20 20 20 20 20 . vals.
13a0: 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c (lambda (key val
13b0: 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 3a ). (debug:
13c0: 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 print 2 "setenv
13d0: 22 20 6b 65 79 20 22 20 22 20 76 61 6c 29 0a 20 " key " " val).
13e0: 20 20 20 20 20 20 28 73 61 66 65 2d 73 65 74 65 (safe-sete
13f0: 6e 76 20 6b 65 79 20 76 61 6c 29 29 29 0a 20 20 nv key val))).
1400: 20 20 28 69 66 20 28 6e 6f 74 20 28 67 65 74 2d (if (not (get-
1410: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
1420: 61 62 6c 65 20 22 4d 54 5f 54 41 52 47 45 54 22 able "MT_TARGET"
1430: 29 29 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 41 ))(setenv "MT_TA
1440: 52 47 45 54 22 20 74 61 72 67 65 74 29 29 0a 20 RGET" target)).
1450: 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 (alist->env-v
1460: 61 72 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ars (hash-table-
1470: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
1480: 69 67 64 61 74 20 22 65 6e 76 2d 6f 76 65 72 72 igdat "env-overr
1490: 69 64 65 22 20 27 28 29 29 29 0a 20 20 20 20 3b ide" '())). ;
14a0: 3b 20 4c 65 74 73 20 75 73 65 20 74 68 69 73 20 ; Lets use this
14b0: 61 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 74 as an opportunit
14c0: 79 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e 4e y to put MT_RUNN
14d0: 41 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 69 72 AME in the envir
14e0: 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 6c 65 74 20 onment. (let
14f0: 28 28 72 75 6e 6e 61 6d 65 20 20 28 69 66 20 69 ((runname (if i
1500: 6e 72 75 6e 6e 61 6d 65 20 69 6e 72 75 6e 6e 61 nrunname inrunna
1510: 6d 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d me (rmt:get-run-
1520: 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e name-from-id run
1530: 2d 69 64 20 61 72 65 61 2d 64 61 74 29 29 29 29 -id area-dat))))
1540: 0a 20 20 20 20 20 20 28 69 66 20 72 75 6e 6e 61 . (if runna
1550: 6d 65 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d me.. (setenv "M
1560: 54 5f 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 T_RUNNAME" runna
1570: 6d 65 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 me).. (debug:pr
1580: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f int 0 "ERROR: no
1590: 20 76 61 6c 75 65 20 66 6f 72 20 72 75 6e 6e 61 value for runna
15a0: 6d 65 20 66 6f 72 20 69 64 20 22 20 72 75 6e 2d me for id " run-
15b0: 69 64 29 29 29 0a 20 20 20 20 28 73 65 74 65 6e id))). (seten
15c0: 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 v "MT_RUN_AREA_H
15d0: 4f 4d 45 22 20 74 6f 70 70 61 74 68 29 29 29 0a OME" toppath))).
15e0: 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 69 74 .(define (set-it
15f0: 65 6d 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d em-env-vars item
1600: 64 61 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 dat). (for-each
1610: 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a (lambda (item).
1620: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
1630: 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 int 2 "setenv "
1640: 28 63 61 72 20 69 74 65 6d 29 20 22 20 22 20 28 (car item) " " (
1650: 63 61 64 72 20 69 74 65 6d 29 29 0a 09 20 20 20 cadr item))..
1660: 20 20 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 (setenv (car
1670: 69 74 65 6d 29 20 28 63 61 64 72 20 69 74 65 6d item) (cadr item
1680: 29 29 29 0a 09 20 20 20 20 69 74 65 6d 64 61 74 ))).. itemdat
1690: 29 29 0a 0a 3b 3b 20 45 76 65 72 79 20 74 69 6d ))..;; Every tim
16a0: 65 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 e can-run-more-t
16b0: 65 73 74 73 20 69 73 20 63 61 6c 6c 65 64 20 69 ests is called i
16c0: 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 64 65 6c ncrement the del
16d0: 61 79 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 57 ay.;;.;; NOTE: W
16e0: 65 20 72 75 6e 20 74 68 69 73 20 73 65 72 76 65 e run this serve
16f0: 72 2d 73 69 64 65 21 21 20 44 6f 20 6e 6f 74 20 r-side!! Do not
1700: 75 73 65 20 74 68 69 73 20 67 6c 6f 62 61 6c 20 use this global
1710: 65 78 63 65 70 74 20 69 6e 20 74 68 65 20 72 75 except in the ru
1720: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1730: 74 65 73 74 73 20 72 6f 75 74 69 6e 65 0a 3b 3b tests routine.;;
1740: 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e .(define *last-n
1750: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 um-running-tests
1760: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 72 75 * 0).(define *ru
1770: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1780: 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 0a tests-count* 0).
1790: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 (define (runs:sh
17a0: 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 rink-can-run-mor
17b0: 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 e-tests-count).
17c0: 20 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e (set! *runs:can
17d0: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
17e0: 63 6f 75 6e 74 2a 20 30 29 29 20 3b 3b 20 28 2f count* 0)) ;; (/
17f0: 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d *runs:can-run-m
1800: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a ore-tests-count*
1810: 20 32 29 29 29 0a 0a 3b 3b 20 54 65 6d 70 6f 72 2)))..;; Tempor
1820: 61 72 79 20 67 6c 6f 62 61 6c 73 2e 20 4d 6f 76 ary globals. Mov
1830: 65 20 74 68 65 73 65 20 69 6e 74 6f 20 74 68 65 e these into the
1840: 20 6c 6f 67 69 63 20 6f 72 20 69 6e 74 6f 20 63 logic or into c
1850: 6f 6d 6d 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 ommon.;;.(define
1860: 20 2a 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d *seen-cant-run-
1870: 74 65 73 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 tests* (make-has
1880: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 75 73 65 h-table)) ;; use
1890: 20 74 6f 20 74 72 61 63 6b 20 74 65 73 74 73 20 to track tests
18a0: 74 68 61 74 20 77 65 20 73 75 73 70 65 63 74 20 that we suspect
18b0: 63 61 6e 6e 6f 74 20 62 65 20 72 75 6e 0a 28 64 cannot be run.(d
18c0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 69 6e 63 2d efine (runs:inc-
18d0: 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 20 74 cant-run-tests t
18e0: 65 73 74 6e 61 6d 65 29 0a 20 20 28 68 61 73 68 estname). (hash
18f0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 73 65 65 -table-set! *see
1900: 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 n-cant-run-tests
1910: 2a 20 74 65 73 74 6e 61 6d 65 0a 09 09 20 20 20 * testname...
1920: 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (+ (hash-table-r
1930: 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 6e ef/default *seen
1940: 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 2a -cant-run-tests*
1950: 20 74 65 73 74 6e 61 6d 65 20 30 29 20 31 29 29 testname 0) 1))
1960: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
1970: 3a 63 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e 69 6e :can-keep-runnin
1980: 67 3f 20 74 65 73 74 6e 61 6d 65 20 6e 29 0a 20 g? testname n).
1990: 20 28 3c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (< (hash-table-
19a0: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 65 ref/default *see
19b0: 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 73 74 73 n-cant-run-tests
19c0: 2a 20 74 65 73 74 6e 61 6d 65 20 30 29 20 6e 29 * testname 0) n)
19d0: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 )..(define *runs
19e0: 3a 64 65 6e 6f 69 73 65 2a 20 28 6d 61 6b 65 2d :denoise* (make-
19f0: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1a00: 6b 65 79 20 3d 3e 20 6c 61 73 74 2d 74 69 6d 65 key => last-time
1a10: 2d 72 61 6e 0a 0a 28 64 65 66 69 6e 65 20 28 72 -ran..(define (r
1a20: 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 6b 65 79 uns:lownoise key
1a30: 20 77 61 69 74 76 61 6c 29 0a 20 20 28 6c 65 74 waitval). (let
1a40: 20 28 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 ((lasttime (has
1a50: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1a60: 75 6c 74 20 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 ult *runs:denois
1a70: 65 2a 20 6b 65 79 20 30 29 29 0a 09 28 63 75 72 e* key 0))..(cur
1a80: 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 rtime (current-s
1a90: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 econds))). (i
1aa0: 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 f (> (- currtime
1ab0: 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 lasttime) waitv
1ac0: 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 al)..(begin.. (
1ad0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1ae0: 2a 72 75 6e 73 3a 64 65 6e 6f 69 73 65 2a 20 6b *runs:denoise* k
1af0: 65 79 20 63 75 72 72 74 69 6d 65 29 0a 09 20 20 ey currtime)..
1b00: 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 #t)..#f)))..(def
1b10: 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 ine (runs:can-ru
1b20: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 75 6e n-more-tests run
1b30: 2d 69 64 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 -id jobgroup max
1b40: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1b50: 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 74 68 area-dat). (th
1b60: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 63 6f 6e read-sleep! (con
1b70: 64 0a 20 20 20 20 20 20 20 20 09 20 20 28 28 3e d. . ((>
1b80: 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d *runs:can-run-m
1b90: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a ore-tests-count*
1ba0: 20 32 30 29 0a 09 09 20 20 20 28 69 66 20 28 72 20)... (if (r
1bb0: 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 77 61 uns:lownoise "wa
1bc0: 69 74 69 6e 67 20 6f 6e 20 74 61 73 6b 73 22 20 iting on tasks"
1bd0: 36 30 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 60)... (de
1be0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
1bf0: 20 22 77 61 69 74 69 6e 67 20 66 6f 72 20 74 61 "waiting for ta
1c00: 73 6b 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 2c sks to complete,
1c10: 20 73 6c 65 65 70 69 6e 67 20 62 72 69 65 66 6c sleeping briefl
1c20: 79 20 2e 2e 2e 22 29 29 0a 09 09 20 20 20 32 29 y ..."))... 2)
1c30: 3b 3b 20 6f 62 76 69 6f 75 73 6c 79 20 68 61 76 ;; obviously hav
1c40: 65 6e 27 74 20 68 61 64 20 61 6e 79 20 77 6f 72 en't had any wor
1c50: 6b 20 74 6f 20 64 6f 20 66 6f 72 20 61 20 77 68 k to do for a wh
1c60: 69 6c 65 0a 20 20 20 20 20 20 20 20 09 20 20 28 ile. . (
1c70: 65 6c 73 65 20 30 29 29 29 0a 20 20 28 6c 65 74 else 0))). (let
1c80: 2a 20 28 28 63 6f 6e 66 69 67 64 61 74 20 20 20 * ((configdat
1c90: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 65 67 (meg
1ca0: 61 74 65 73 74 3a 61 72 65 61 2d 63 6f 6e 66 69 atest:area-confi
1cb0: 67 64 61 74 20 61 72 65 61 2d 64 61 74 29 29 0a gdat area-dat)).
1cc0: 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 . (num-running
1cd0: 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a (rmt:
1ce0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
1cf0: 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 20 61 running run-id a
1d00: 72 65 61 2d 64 61 74 29 29 0a 09 20 28 6e 75 6d rea-dat)).. (num
1d10: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1d20: 72 6f 75 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f roup (rmt:get-co
1d30: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
1d40: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 72 75 g-in-jobgroup ru
1d50: 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 20 61 72 n-id jobgroup ar
1d60: 65 61 2d 64 61 74 29 29 0a 09 20 28 6a 6f 62 2d ea-dat)).. (job-
1d70: 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 group-limit
1d80: 20 20 20 20 28 6c 65 74 20 28 28 6a 6f 62 67 2d (let ((jobg-
1d90: 63 6f 75 6e 74 20 28 63 6f 6e 66 69 67 2d 6c 6f count (config-lo
1da0: 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
1db0: 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 jobgroups" jobgr
1dc0: 6f 75 70 29 29 29 0a 09 09 09 09 20 20 20 20 28 oup)))..... (
1dd0: 69 66 20 28 73 74 72 69 6e 67 3f 20 6a 6f 62 67 if (string? jobg
1de0: 2d 63 6f 75 6e 74 29 0a 09 09 09 09 09 28 73 74 -count)......(st
1df0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6a 6f 62 ring->number job
1e00: 67 2d 63 6f 75 6e 74 29 0a 09 09 09 09 09 6a 6f g-count)......jo
1e10: 62 67 2d 63 6f 75 6e 74 29 29 29 29 0a 20 20 20 bg-count)))).
1e20: 20 28 69 66 20 28 3e 20 28 2b 20 6e 75 6d 2d 72 (if (> (+ num-r
1e30: 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 unning num-runni
1e40: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 29 20 ng-in-jobgroup)
1e50: 30 29 0a 09 28 73 65 74 21 20 2a 72 75 6e 73 3a 0)..(set! *runs:
1e60: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
1e70: 74 73 2d 63 6f 75 6e 74 2a 20 28 2b 20 2a 72 75 ts-count* (+ *ru
1e80: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1e90: 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 31 29 29 tests-count* 1))
1ea0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
1eb0: 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 eq? *last-num-ru
1ec0: 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d nning-tests* num
1ed0: 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 28 62 65 67 -running))..(beg
1ee0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
1ef0: 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 nt 2 "max-concur
1f00: 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 rent-jobs: " max
1f10: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1f20: 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a ", num-running:
1f30: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a " num-running).
1f40: 09 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 6e . (set! *last-n
1f50: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 um-running-tests
1f60: 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 * num-running)))
1f70: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
1f80: 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 q? 0 *globalexit
1f90: 73 74 61 74 75 73 2a 29 29 0a 09 28 6c 69 73 74 status*))..(list
1fa0: 20 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 #f num-running
1fb0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1fc0: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
1fd0: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d urrent-jobs job-
1fe0: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 0a 09 28 6c group-limit)..(l
1ff0: 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e et ((can-not-run
2000: 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 -more (cond.....
2010: 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 ;; if max-concu
2020: 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 rrent-jobs is se
2030: 74 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 t and the number
2040: 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 running is grea
2050: 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 ter ..... ;; tha
2060: 6e 20 69 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 n it than cannot
2070: 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 run more jobs..
2080: 09 09 09 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f ... ((and max-co
2090: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 3e ncurrent-jobs (>
20a0: 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6d 61 = num-running ma
20b0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
20c0: 73 29 29 0a 09 09 09 09 20 20 28 69 66 20 28 72 s))..... (if (r
20d0: 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 22 6d 63 uns:lownoise "mc
20e0: 6a 20 6d 73 67 22 20 36 30 29 0a 09 09 09 09 20 j msg" 60).....
20f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2100: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 t 0 "WARNING: Ma
2110: 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 x running jobs e
2120: 78 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 xceeded, current
2130: 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a number running:
2140: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a " num-running .
2150: 09 09 09 09 09 09 20 20 20 22 2c 20 6d 61 78 5f ...... ", max_
2160: 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a concurrent_jobs:
2170: 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e " max-concurren
2180: 74 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 23 t-jobs))..... #
2190: 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f t)..... ;; if jo
21a0: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 b-group-limit is
21b0: 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 set and number
21c0: 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 of jobs in the g
21d0: 72 6f 75 70 20 69 73 20 67 72 65 61 74 65 72 0a roup is greater.
21e0: 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 .... ;; than the
21f0: 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e limit then cann
2200: 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 ot run more jobs
2210: 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 of this kind...
2220: 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f .. ((and job-gro
2230: 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 up-limit.....
2240: 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e (>= num-runn
2250: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
2260: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 job-group-limit)
2270: 29 0a 09 09 09 09 20 20 28 69 66 20 28 72 75 6e )..... (if (run
2280: 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 s:lownoise (conc
2290: 20 22 6d 61 78 6a 6f 62 67 72 6f 75 70 20 22 20 "maxjobgroup "
22a0: 6a 6f 62 67 72 6f 75 70 29 20 36 30 29 0a 09 09 jobgroup) 60)...
22b0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
22c0: 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a rint 1 "WARNING:
22d0: 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 number of jobs
22e0: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e " num-running-in
22f0: 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 09 -jobgroup ......
2300: 09 20 20 20 22 20 69 6e 20 6a 6f 62 67 72 6f 75 . " in jobgrou
2310: 70 20 5c 22 22 20 6a 6f 62 67 72 6f 75 70 20 22 p \"" jobgroup "
2320: 5c 22 20 65 78 63 65 65 64 73 20 6c 69 6d 69 74 \" exceeds limit
2330: 20 6f 66 20 22 20 6a 6f 62 2d 67 72 6f 75 70 2d of " job-group-
2340: 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 20 23 74 limit))..... #t
2350: 29 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 29 )..... (else #f)
2360: 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f ))).. (list (no
2370: 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f t can-not-run-mo
2380: 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 re) num-running
2390: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
23a0: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
23b0: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d urrent-jobs job-
23c0: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 group-limit)))))
23d0: 0a 0a 0a 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 ...;; test-name
23e0: 73 3a 20 43 6f 6d 6d 61 20 73 65 70 61 72 61 74 s: Comma separat
23f0: 65 64 20 70 61 74 74 65 72 6e 73 20 73 61 6d 65 ed patterns same
2400: 20 61 73 20 74 65 73 74 2d 70 61 74 74 73 20 62 as test-patts b
2410: 75 74 20 75 73 65 64 20 69 6e 20 73 65 6c 65 63 ut used in selec
2420: 74 69 6f 6e 20 0a 3b 3b 20 20 20 20 20 20 20 20 tion .;;
2430: 20 20 20 20 20 20 6f 66 20 74 65 73 74 73 20 74 of tests t
2440: 6f 20 72 75 6e 2e 20 54 68 65 20 69 74 65 6d 20 o run. The item
2450: 70 6f 72 74 69 6f 6e 73 20 61 72 65 20 6e 6f 74 portions are not
2460: 20 72 65 73 70 65 63 74 65 64 2e 0a 3b 3b 20 20 respected..;;
2470: 20 20 20 20 20 20 20 20 20 20 20 20 46 49 58 4d FIXM
2480: 45 3a 20 65 72 72 6f 72 20 6f 75 74 20 69 66 20 E: error out if
2490: 2f 70 61 74 74 20 73 70 65 63 69 66 69 65 64 0a /patt specified.
24a0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 0a 28 ;; .(
24b0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e define (runs:run
24c0: 2d 74 65 73 74 73 20 74 61 72 67 65 74 20 72 75 -tests target ru
24d0: 6e 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 nname test-patts
24e0: 20 75 73 65 72 20 66 6c 61 67 73 20 61 72 65 61 user flags area
24f0: 2d 64 61 74 20 23 21 6b 65 79 20 28 72 75 6e 2d -dat #!key (run-
2500: 63 6f 75 6e 74 20 33 29 29 20 3b 3b 20 74 65 73 count 3)) ;; tes
2510: 74 2d 6e 61 6d 65 73 0a 20 20 28 6c 65 74 2a 20 t-names. (let*
2520: 28 28 63 6f 6e 66 69 67 64 61 74 20 20 20 20 20 ((configdat
2530: 20 20 20 20 20 28 6d 65 67 61 74 65 73 74 3a 61 (megatest:a
2540: 72 65 61 2d 63 6f 6e 66 69 67 64 61 74 20 61 72 rea-configdat ar
2550: 65 61 2d 64 61 74 29 29 0a 09 20 28 74 6f 70 70 ea-dat)).. (topp
2560: 61 74 68 20 20 20 20 20 20 20 20 20 20 20 20 28 ath (
2570: 6d 65 67 61 74 65 73 74 3a 61 72 65 61 2d 70 61 megatest:area-pa
2580: 74 68 20 20 20 20 20 20 61 72 65 61 2d 64 61 74 th area-dat
2590: 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 )).. (keys
25a0: 20 20 20 20 20 20 20 20 20 28 6b 65 79 73 3a 63 (keys:c
25b0: 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 onfig-get-fields
25c0: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
25d0: 6b 65 79 76 61 6c 73 20 20 20 20 20 20 20 20 20 keyvals
25e0: 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d (keys:target-
25f0: 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 >keyval keys tar
2600: 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 get)).. (run-id
2610: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 (rmt
2620: 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 6b 65 :register-run ke
2630: 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 22 6e yvals runname "n
2640: 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 20 61 ew" "n/a" user a
2650: 72 65 61 2d 64 61 74 29 29 20 20 3b 3b 20 20 74 rea-dat)) ;; t
2660: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 28 64 est-name))).. (d
2670: 65 66 65 72 72 65 64 20 20 20 20 20 20 20 20 20 eferred
2680: 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 '()) ;; delay r
2690: 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e unning these sin
26a0: 63 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 ce they have a w
26b0: 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 28 aiton clause.. (
26c0: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 20 20 20 runconfigf
26d0: 20 20 20 28 63 6f 6e 63 20 20 74 6f 70 70 61 74 (conc toppat
26e0: 68 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 h "/runconfigs.c
26f0: 6f 6e 66 69 67 22 29 29 0a 09 20 28 74 65 73 74 onfig")).. (test
2700: 2d 72 65 63 6f 72 64 73 20 20 20 20 20 20 20 28 -records (
2710: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2720: 29 0a 09 20 3b 3b 20 6e 65 65 64 20 74 6f 20 70 ).. ;; need to p
2730: 72 6f 63 65 73 73 20 72 75 6e 63 6f 6e 66 69 67 rocess runconfig
2740: 73 20 62 65 66 6f 72 65 20 67 65 6e 65 72 61 74 s before generat
2750: 69 6e 67 20 74 68 65 73 65 20 6c 69 73 74 73 0a ing these lists.
2760: 09 20 28 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 . (all-tests-reg
2770: 69 73 74 72 79 20 23 66 29 20 20 3b 3b 20 28 74 istry #f) ;; (t
2780: 65 73 74 73 3a 67 65 74 2d 61 6c 6c 29 29 20 3b ests:get-all)) ;
2790: 3b 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c ; (tests:get-val
27a0: 69 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 id-tests (make-h
27b0: 61 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d ash-table) test-
27c0: 73 65 61 72 63 68 2d 70 61 74 68 29 29 20 3b 3b search-path)) ;;
27d0: 20 61 6c 6c 20 76 61 6c 69 64 20 74 65 73 74 73 all valid tests
27e0: 20 74 6f 20 63 68 65 63 6b 20 77 61 69 74 6f 6e to check waiton
27f0: 20 6e 61 6d 65 73 0a 09 20 28 61 6c 6c 2d 74 65 names.. (all-te
2800: 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 23 66 29 st-names #f)
2810: 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 ;; (hash-table
2820: 2d 6b 65 79 73 20 61 6c 6c 2d 74 65 73 74 73 2d -keys all-tests-
2830: 72 65 67 69 73 74 72 79 29 29 0a 09 20 28 74 65 registry)).. (te
2840: 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 20 20 20 st-names
2850: 20 23 66 29 20 20 3b 3b 20 28 74 65 73 74 73 3a #f) ;; (tests:
2860: 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 filter-test-name
2870: 73 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 s all-test-names
2880: 20 74 65 73 74 2d 70 61 74 74 73 29 29 0a 09 20 test-patts))..
2890: 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 (required-tests
28a0: 20 20 20 20 23 66 29 20 20 3b 3b 28 6c 73 65 74 #f) ;;(lset
28b0: 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 65 71 -intersection eq
28c0: 75 61 6c 3f 20 28 73 74 72 69 6e 67 2d 73 70 6c ual? (string-spl
28d0: 69 74 20 74 65 73 74 2d 70 61 74 74 73 20 22 2c it test-patts ",
28e0: 22 29 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 ") test-names)))
28f0: 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ;; test-names))
2900: 20 3b 3b 20 41 64 64 65 64 20 74 65 73 74 2d 6e ;; Added test-n
2910: 61 6d 65 73 20 61 73 20 69 6e 69 74 69 61 6c 20 ames as initial
2920: 66 6f 72 20 72 65 71 75 69 72 65 64 2d 74 65 73 for required-tes
2930: 74 73 20 62 75 74 20 74 68 61 74 20 66 61 69 6c ts but that fail
2940: 65 64 20 74 6f 20 77 6f 72 6b 0a 09 20 28 74 61 ed to work.. (ta
2950: 73 6b 2d 6b 65 79 20 20 20 20 20 20 20 20 20 20 sk-key
2960: 20 28 63 6f 6e 63 20 28 68 61 73 68 2d 74 61 62 (conc (hash-tab
2970: 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 le->alist flags)
2980: 20 22 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e " " (get-host-n
2990: 61 6d 65 29 20 22 20 22 20 28 63 75 72 72 65 6e ame) " " (curren
29a0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a t-process-id))).
29b0: 09 20 28 74 64 62 64 61 74 20 20 20 20 20 20 20 . (tdbdat
29c0: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 (tasks:ope
29d0: 6e 2d 64 62 20 61 72 65 61 2d 64 61 74 29 29 29 n-db area-dat)))
29e0: 0a 0a 20 20 20 20 28 69 66 20 28 74 61 73 6b 73 .. (if (tasks
29f0: 3a 6e 65 65 64 2d 73 65 72 76 65 72 20 72 75 6e :need-server run
2a00: 2d 69 64 20 61 72 65 61 2d 64 61 74 29 28 74 61 -id area-dat)(ta
2a10: 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 sks:start-and-wa
2a20: 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 20 74 64 it-for-server td
2a30: 62 64 61 74 20 72 75 6e 2d 69 64 20 31 30 29 29 bdat run-id 10))
2a40: 0a 0a 20 20 20 20 28 73 65 74 2d 73 69 67 6e 61 .. (set-signa
2a50: 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 l-handler! signa
2a60: 6c 2f 69 6e 74 0a 09 09 09 20 28 6c 61 6d 62 64 l/int.... (lambd
2a70: 61 20 28 73 69 67 6e 75 6d 29 0a 09 09 09 20 20 a (signum)....
2a80: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
2a90: 69 67 6e 75 6d 29 0a 09 09 09 20 20 20 28 70 72 ignum).... (pr
2aa0: 69 6e 74 20 22 52 65 63 65 69 76 65 64 20 73 69 int "Received si
2ab0: 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 2c gnal " signum ",
2ac0: 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 62 65 66 cleaning up bef
2ad0: 6f 72 65 20 65 78 69 74 2e 20 50 6c 65 61 73 65 ore exit. Please
2ae0: 20 77 61 69 74 2e 2e 2e 22 29 0a 09 09 09 20 20 wait...")....
2af0: 20 28 6c 65 74 20 28 28 74 64 62 64 61 74 20 28 (let ((tdbdat (
2b00: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 61 72 tasks:open-db ar
2b10: 65 61 2d 64 61 74 29 29 29 0a 09 09 09 20 20 20 ea-dat)))....
2b20: 20 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 74 (rmt:tasks-set
2b30: 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 -state-given-par
2b40: 61 6d 2d 6b 65 79 20 74 61 73 6b 2d 6b 65 79 20 am-key task-key
2b50: 22 6b 69 6c 6c 65 64 22 29 29 0a 09 09 09 20 20 "killed"))....
2b60: 20 28 70 72 69 6e 74 20 22 4b 69 6c 6c 65 64 20 (print "Killed
2b70: 62 79 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e by signal " sign
2b80: 75 6d 20 22 2e 20 45 78 69 74 69 6e 67 22 29 0a um ". Exiting").
2b90: 09 09 09 20 20 20 28 65 78 69 74 29 29 29 0a 0a ... (exit)))..
2ba0: 20 20 20 20 3b 3b 20 72 65 67 69 73 74 65 72 20 ;; register
2bb0: 74 68 69 73 20 72 75 6e 20 69 6e 20 6d 6f 6e 69 this run in moni
2bc0: 74 6f 72 2e 64 62 0a 20 20 20 20 28 72 6d 74 3a tor.db. (rmt:
2bd0: 74 61 73 6b 73 2d 61 64 64 20 22 72 75 6e 2d 74 tasks-add "run-t
2be0: 65 73 74 73 22 20 75 73 65 72 20 74 61 72 67 65 ests" user targe
2bf0: 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 70 t runname test-p
2c00: 61 74 74 73 20 74 61 73 6b 2d 6b 65 79 20 61 72 atts task-key ar
2c10: 65 61 2d 64 61 74 29 20 3b 3b 20 70 61 72 61 6d ea-dat) ;; param
2c20: 73 29 0a 20 20 20 20 28 72 6d 74 3a 74 61 73 6b s). (rmt:task
2c30: 73 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 s-set-state-give
2c40: 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 74 61 73 6b n-param-key task
2c50: 2d 6b 65 79 20 22 72 75 6e 6e 69 6e 67 22 20 61 -key "running" a
2c60: 72 65 61 2d 64 61 74 29 0a 20 20 20 20 28 72 75 rea-dat). (ru
2c70: 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 73 74 2d ns:set-megatest-
2c80: 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 env-vars run-id
2c90: 61 72 65 61 2d 64 61 74 20 69 6e 6b 65 79 73 3a area-dat inkeys:
2ca0: 20 6b 65 79 73 20 69 6e 72 75 6e 6e 61 6d 65 3a keys inrunname:
2cb0: 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 runname) ;; the
2cc0: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
2cd0: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
2ce0: 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 28 69 g process. (i
2cf0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
2d00: 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 runconfigf)..(se
2d10: 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 tup-env-defaults
2d20: 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d runconfigf run-
2d30: 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e id *already-seen
2d40: 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a -runconfig-info*
2d50: 20 6b 65 79 76 61 6c 73 20 74 61 72 67 65 74 29 keyvals target)
2d60: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
2d70: 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 "WARNING: You d
2d80: 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e o not have a run
2d90: 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 config file: "
2da0: 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 0a 20 20 runconfigf))..
2db0: 20 20 3b 3b 20 4e 6f 77 20 67 65 6e 65 72 61 74 ;; Now generat
2dc0: 65 20 61 6c 6c 20 74 68 65 20 74 65 73 74 73 20 e all the tests
2dd0: 6c 69 73 74 73 0a 20 20 20 20 28 73 65 74 21 20 lists. (set!
2de0: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
2df0: 72 79 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c ry (tests:get-al
2e00: 6c 20 61 72 65 61 2d 64 61 74 29 29 0a 20 20 20 l area-dat)).
2e10: 20 28 73 65 74 21 20 61 6c 6c 2d 74 65 73 74 2d (set! all-test-
2e20: 6e 61 6d 65 73 20 20 20 20 20 28 68 61 73 68 2d names (hash-
2e30: 74 61 62 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 table-keys all-t
2e40: 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 29 0a ests-registry)).
2e50: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e (set! test-n
2e60: 61 6d 65 73 20 20 20 20 20 20 20 20 20 28 74 65 ames (te
2e70: 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d sts:filter-test-
2e80: 6e 61 6d 65 73 20 61 6c 6c 2d 74 65 73 74 2d 6e names all-test-n
2e90: 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 ames test-patts)
2ea0: 29 0a 20 20 20 20 28 73 65 74 21 20 72 65 71 75 ). (set! requ
2eb0: 69 72 65 64 2d 74 65 73 74 73 20 20 20 20 20 28 ired-tests (
2ec0: 6c 73 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f lset-intersectio
2ed0: 6e 20 65 71 75 61 6c 3f 20 28 73 74 72 69 6e 67 n equal? (string
2ee0: 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 74 -split test-patt
2ef0: 73 20 22 2c 22 29 20 74 65 73 74 2d 6e 61 6d 65 s ",") test-name
2f00: 73 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 s)). . ;;
2f10: 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 look up all test
2f20: 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 s matching the c
2f30: 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c omma separated l
2f40: 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a ist of globs in.
2f50: 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 ;; test-patt
2f60: 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 s (using % as wi
2f70: 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 3b 3b 20 ldcard).. ;;
2f80: 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 (set! test-names
2f90: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
2fa0: 74 65 73 20 28 74 65 73 74 73 3a 67 65 74 2d 76 tes (tests:get-v
2fb0: 61 6c 69 64 2d 74 65 73 74 73 20 74 6f 70 70 61 alid-tests toppa
2fc0: 74 68 20 74 65 73 74 2d 70 61 74 74 73 29 29 29 th test-patts)))
2fd0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
2fe0: 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 73 20 t-info 0 "tests
2ff0: 73 65 61 72 63 68 20 70 61 74 68 3a 20 22 20 28 search path: " (
3000: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d tests:get-tests-
3010: 73 65 61 72 63 68 2d 70 61 74 68 20 63 6f 6e 66 search-path conf
3020: 69 67 64 61 74 20 61 72 65 61 2d 64 61 74 29 29 igdat area-dat))
3030: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3040: 74 2d 69 6e 66 6f 20 30 20 22 61 6c 6c 20 74 65 t-info 0 "all te
3050: 73 74 73 3a 20 20 22 20 28 73 74 72 69 6e 67 2d sts: " (string-
3060: 69 6e 74 65 72 73 70 65 72 73 65 20 28 73 6f 72 intersperse (sor
3070: 74 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 t all-test-names
3080: 20 73 74 72 69 6e 67 3c 29 20 22 20 22 29 29 0a string<) " ")).
3090: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
30a0: 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 20 6e 61 -info 0 "test na
30b0: 6d 65 73 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 mes: " (string-i
30c0: 6e 74 65 72 73 70 65 72 73 65 20 28 73 6f 72 74 ntersperse (sort
30d0: 20 74 65 73 74 2d 6e 61 6d 65 73 20 73 74 72 69 test-names stri
30e0: 6e 67 3c 29 20 22 20 22 29 29 0a 0a 20 20 20 20 ng<) " "))..
30f0: 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 ;; on the first
3100: 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 pass or call to
3110: 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 46 41 run-tests set FA
3120: 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 ILS to NOT_START
3130: 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 ED if. ;; -ke
3140: 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 63 69 epgoing is speci
3150: 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 65 71 fied. (if (eq
3160: 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 ? *passnum* 0)..
3170: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 49 73 20 (begin.. ;; Is
3180: 74 68 69 73 20 73 74 69 6c 6c 20 6e 65 63 65 73 this still neces
3190: 73 61 72 79 3f 20 49 20 74 68 69 6e 6b 20 6e 6f sary? I think no
31a0: 74 2e 20 55 6e 72 65 61 63 68 61 62 6c 65 20 74 t. Unreachable t
31b0: 65 73 74 73 20 61 72 65 20 6d 61 72 6b 65 64 20 ests are marked
31c0: 61 73 20 73 75 63 68 20 61 6e 64 20 0a 09 20 20 as such and ..
31d0: 3b 3b 20 73 68 6f 75 6c 64 20 6e 6f 74 20 63 61 ;; should not ca
31e0: 75 73 65 20 70 72 6f 62 6c 65 6d 73 20 68 65 72 use problems her
31f0: 65 2e 0a 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 68 e... ;;.. ;; h
3200: 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 ave to delete te
3210: 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 st records where
3220: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e NOT_STARTED sin
3230: 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 ce they can caus
3240: 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 e -keepgoing to
3250: 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b .. ;; get stuck
3260: 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 due to becoming
3270: 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 inaccessible fr
3280: 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 om a failed test
3290: 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 . I.e. if test B
32a0: 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 depends .. ;;
32b0: 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 on test A but te
32c0: 73 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 st B reached the
32d0: 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 point on being
32e0: 72 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f registered as NO
32f0: 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 T_STARTED and te
3300: 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 st.. ;; A faile
3310: 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f d for some reaso
3320: 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e n then on re-run
3330: 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e using -keepgoin
3340: 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 g the run can ne
3350: 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 ver complete...
3360: 20 3b 3b 0a 09 20 20 3b 3b 20 28 72 6d 74 3a 67 ;;.. ;; (rmt:g
3370: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 64 65 6c eneral-call 'del
3380: 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 61 ete-tests-in-sta
3390: 74 65 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 te run-id "NOT_S
33a0: 54 41 52 54 45 44 22 29 0a 09 20 20 0a 09 20 20 TARTED").. ..
33b0: 3b 3b 20 4e 6f 77 20 63 6f 6e 76 65 72 74 20 46 ;; Now convert F
33c0: 41 49 4c 20 61 6e 64 20 61 6e 79 74 68 69 6e 67 AIL and anything
33d0: 20 69 6e 20 61 6c 6c 6f 77 2d 61 75 74 6f 2d 72 in allow-auto-r
33e0: 65 72 75 6e 20 74 6f 20 4e 4f 54 5f 53 54 41 52 erun to NOT_STAR
33f0: 54 45 44 0a 09 20 20 3b 3b 0a 09 20 20 28 66 6f TED.. ;;.. (fo
3400: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
3410: 73 74 61 74 65 29 0a 09 09 20 20 20 20 20 20 28 state)... (
3420: 72 6d 74 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 rmt:set-tests-st
3430: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
3440: 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 73 74 61 d test-names sta
3450: 74 65 20 23 66 20 22 4e 4f 54 5f 53 54 41 52 54 te #f "NOT_START
3460: 45 44 22 20 73 74 61 74 65 20 61 72 65 61 2d 64 ED" state area-d
3470: 61 74 29 29 0a 09 09 20 20 20 20 28 73 74 72 69 at))... (stri
3480: 6e 67 2d 73 70 6c 69 74 20 28 6f 72 20 28 63 6f ng-split (or (co
3490: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
34a0: 66 69 67 64 61 74 20 22 73 65 74 75 70 22 20 22 figdat "setup" "
34b0: 61 6c 6c 6f 77 2d 61 75 74 6f 2d 72 65 72 75 6e allow-auto-rerun
34c0: 22 29 20 22 22 29 29 29 29 29 0a 0a 20 20 20 20 ") "")))))..
34d0: 3b 3b 20 45 6e 73 75 72 65 20 61 6c 6c 20 74 65 ;; Ensure all te
34e0: 73 74 73 20 61 72 65 20 72 65 67 69 73 74 65 72 sts are register
34f0: 65 64 20 69 6e 20 74 68 65 20 74 65 73 74 5f 6d ed in the test_m
3500: 65 74 61 20 74 61 62 6c 65 0a 20 20 20 20 28 72 eta table. (r
3510: 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 uns:update-all-t
3520: 65 73 74 5f 6d 65 74 61 20 23 66 20 61 72 65 61 est_meta #f area
3530: 2d 64 61 74 29 0a 0a 20 20 20 20 3b 3b 20 6e 6f -dat).. ;; no
3540: 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 w add non-direct
3550: 6c 79 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 ly referenced de
3560: 70 65 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e pendencies (i.e.
3570: 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 3b 3b 3d waiton). ;;=
3580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35c0: 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 72 65 66 =====. ;; ref
35d0: 61 63 74 6f 72 69 6e 67 20 74 68 69 73 20 62 6c actoring this bl
35e0: 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 3a 67 ock into tests:g
35f0: 65 74 2d 66 75 6c 6c 2d 64 61 74 61 0a 20 20 20 et-full-data.
3600: 20 3b 3b 0a 20 20 20 20 3b 3b 20 57 68 61 74 20 ;;. ;; What
3610: 68 61 70 70 65 6e 64 65 64 2c 20 74 68 69 73 20 happended, this
3620: 63 6f 64 65 20 69 73 20 6e 6f 77 20 64 75 70 6c code is now dupl
3630: 69 63 61 74 65 64 20 69 6e 20 74 65 73 74 73 21 icated in tests!
3640: 3f 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 3d ?. ;;. ;;=
3650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3690: 3d 3d 3d 3d 3d 0a 20 20 20 20 28 69 66 20 28 6e =====. (if (n
36a0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e ot (null? test-n
36b0: 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f ames))..(let loo
36c0: 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 p ((hed (car tes
36d0: 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 t-names))... (
36e0: 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e 61 tal (cdr test-na
36f0: 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 3b mes))) ;
3700: 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 ; 'return-procs
3710: 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 tells the config
3720: 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 20 reader to prep
3730: 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 running system b
3740: 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f 63 ut return a proc
3750: 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 .. (change-dire
3760: 63 74 6f 72 79 20 74 6f 70 70 61 74 68 29 20 3b ctory toppath) ;
3770: 3b 20 50 4c 45 41 53 45 20 4f 50 54 49 4d 49 5a ; PLEASE OPTIMIZ
3780: 45 20 4d 45 21 21 21 20 49 20 74 68 69 6e 6b 20 E ME!!! I think
3790: 74 68 69 73 20 73 68 6f 75 6c 64 20 62 65 20 61 this should be a
37a0: 20 6e 6f 2d 6f 70 20 62 75 74 20 74 68 65 72 65 no-op but there
37b0: 20 61 72 65 20 73 65 76 65 72 61 6c 20 70 6c 61 are several pla
37c0: 63 65 73 20 77 68 65 72 65 20 63 68 61 6e 67 65 ces where change
37d0: 2d 64 69 72 65 63 74 6f 72 69 65 73 20 63 6f 75 -directories cou
37e0: 6c 64 20 62 65 20 68 61 70 70 65 6e 69 6e 67 2e ld be happening.
37f0: 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
3800: 54 45 53 54 5f 4e 41 4d 45 22 20 68 65 64 29 20 TEST_NAME" hed)
3810: 3b 3b 20 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 ;; .. (let* ((c
3820: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
3830: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 t-testconfig hed
3840: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
3850: 74 72 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 try 'return-proc
3860: 73 20 61 72 65 61 2d 64 61 74 29 29 0a 09 09 20 s area-dat))...
3870: 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 (waitons (let ((
3880: 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 instr (if config
3890: 20 0a 09 09 09 09 09 20 20 20 28 63 6f 6e 66 69 ...... (confi
38a0: 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
38b0: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
38c0: 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 20 waiton")......
38d0: 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f (begin ;; No co
38e0: 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 nfig means this
38f0: 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e is a non-existan
3900: 74 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 t test......
3910: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3920: 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 "ERROR: non-exis
3930: 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 tent required te
3940: 73 74 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 st \"" hed "\"")
3950: 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 69 74 ...... (exit
3960: 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 20 28 1))))).... (
3970: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3980: 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 8 "waitons stri
3990: 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 0a 09 ng is " instr)..
39a0: 09 09 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 .. (let ((new
39b0: 77 61 69 74 6f 6e 73 0a 09 09 09 09 20 20 20 28 waitons..... (
39c0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f string-split (co
39d0: 6e 64 0a 09 09 09 09 09 09 20 20 28 28 70 72 6f nd....... ((pro
39e0: 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 cedure? instr)..
39f0: 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 72 ..... (let ((r
3a00: 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 es (instr)))....
3a10: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
3a20: 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 rint-info 8 "wai
3a30: 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 ton procedure re
3a40: 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
3a50: 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
3a60: 20 22 20 68 65 64 29 0a 09 09 09 09 09 09 20 20 " hed).......
3a70: 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 09 20 res)).......
3a80: 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 ((string? instr
3a90: 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 ) instr)....
3aa0: 09 09 09 20 20 28 65 6c 73 65 20 0a 09 09 09 09 ... (else .....
3ab0: 09 09 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 .. ;; NOTE: Th
3ac0: 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
3ad0: 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
3ae0: 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 waitons! ;; (deb
3af0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
3b00: 52 3a 20 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e R: something wen
3b10: 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 t wrong in proce
3b20: 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f ssing waitons fo
3b30: 72 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 r test " hed)...
3b40: 09 09 09 09 20 20 20 22 22 29 29 29 29 29 0a 09 .... "")))))..
3b50: 09 09 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 .. (filter
3b60: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
3b70: 09 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 .(if (hash-table
3b80: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c -ref/default all
3b90: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
3ba0: 78 20 23 66 29 0a 09 09 09 09 09 20 20 20 20 23 x #f)...... #
3bb0: 74 0a 09 09 09 09 09 20 20 20 20 28 62 65 67 69 t...... (begi
3bc0: 6e 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 65 n...... (de
3bd0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
3be0: 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 OR: test " hed "
3bf0: 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 has unrecognise
3c00: 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d d waiton testnam
3c10: 65 20 22 20 78 29 0a 09 09 09 09 09 20 20 20 20 e " x)......
3c20: 20 20 23 66 29 29 29 0a 09 09 09 09 20 20 20 20 #f))).....
3c30: 20 20 6e 65 77 77 61 69 74 6f 6e 73 29 29 29 29 newwaitons))))
3c40: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
3c50: 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 int-info 8 "wait
3c60: 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a ons: " waitons).
3c70: 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f . ;; check fo
3c80: 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 r hed in waitons
3c90: 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 => this would b
3ca0: 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f e circular, remo
3cb0: 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 ve it and issue
3cc0: 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 an.. ;; error
3cd0: 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 .. (if (membe
3ce0: 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 r hed waitons)..
3cf0: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
3d00: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
3d10: 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 R: test " hed "
3d20: 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c has listed itsel
3d30: 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 f as a waiton, p
3d40: 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 lease correct th
3d50: 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 is!")... (set!
3d60: 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 waitons (filter
3d70: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
3d80: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
3d90: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 waitons))))..
3da0: 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 6d .. ;; (item
3db0: 73 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 s (items:get-i
3dc0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
3dd0: 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 20 config)))..
3de0: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
3df0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3e00: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
3e10: 64 20 23 66 29 29 0a 09 09 28 68 61 73 68 2d 74 d #f))...(hash-t
3e20: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
3e30: 65 63 6f 72 64 73 0a 09 09 09 09 20 68 65 64 20 ecords..... hed
3e40: 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 (vector hed
3e50: 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 20 20 63 ;; 0...... c
3e60: 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 onfig ;; 1.....
3e70: 09 20 20 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b . waitons ;;
3e80: 20 32 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 2...... (co
3e90: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
3ea0: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
3eb0: 22 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 " "priority")
3ec0: 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a ;; priority 3.
3ed0: 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 ..... (let (
3ee0: 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 (items (has
3ef0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3f00: 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d ult config "item
3f10: 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 s" #f)) ;; items
3f20: 20 34 0a 09 09 09 09 09 09 20 20 20 28 69 74 65 4....... (ite
3f30: 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 mstable (hash-ta
3f40: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
3f50: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 config "itemstab
3f60: 6c 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 le" #f))) ......
3f70: 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 ;; if eit
3f80: 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 her items or ite
3f90: 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 ms table is a pr
3fa0: 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 oc return it so
3fb0: 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 test running....
3fc0: 09 09 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 .. ;; proc
3fd0: 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 ess can know to
3fe0: 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 call items:get-i
3ff0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
4000: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
4010: 69 66 20 65 69 74 68 65 72 20 69 73 20 61 20 6c if either is a l
4020: 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 ist and none is
4030: 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 a proc go ahead
4040: 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 and call get-ite
4050: 6d 73 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ms...... ;
4060: 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 ; otherwise retu
4070: 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 rn #f - this is
4080: 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 not an iterated
4090: 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 20 20 test......
40a0: 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 (cond.......((p
40b0: 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 rocedure? items)
40c0: 20 20 20 20 20 20 0a 09 09 09 09 09 09 20 28 64 ....... (d
40d0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
40e0: 34 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 4 "items is a pr
40f0: 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 ocedure, will ca
4100: 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 lc later")......
4110: 09 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 . items)
4120: 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 ;; calc late
4130: 72 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 r.......((proced
4140: 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ure? itemstable)
4150: 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 ....... (debug:p
4160: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 rint-info 4 "ite
4170: 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f mstable is a pro
4180: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
4190: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
41a0: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 itemstable)
41b0: 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 ;; calc later
41c0: 0a 09 09 09 09 09 09 28 28 66 69 6c 74 65 72 20 .......((filter
41d0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
41e0: 09 09 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c ... (let ((val
41f0: 20 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 (car x)))......
4200: 09 09 20 20 20 20 20 28 69 66 20 28 70 72 6f 63 .. (if (proc
4210: 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 edure? val) val
4220: 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 28 61 #f)))........ (a
4230: 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f ppend (if (list?
4240: 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 items) items '(
4250: 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 ))......... (if
4260: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
4270: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
4280: 29 29 29 29 0a 09 09 09 09 09 09 20 27 68 61 76 ))))....... 'hav
4290: 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 e-procedure)....
42a0: 09 09 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 ...((or (list? i
42b0: 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d tems)(list? item
42c0: 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 stable)) ;; calc
42d0: 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 65 62 now....... (deb
42e0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
42f0: 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 "items and items
4300: 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
4310: 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
4320: 09 09 09 09 09 20 20 20 22 20 20 20 20 69 74 65 ..... " ite
4330: 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 ms: " items " it
4340: 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d emstable: " item
4350: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
4360: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
4370: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
4380: 69 67 29 29 0a 09 09 09 09 09 09 28 65 6c 73 65 ig)).......(else
4390: 20 23 66 29 29 29 20 20 20 20 20 20 20 20 20 20 #f)))
43a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43b0: 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 ;; not iterated
43c0: 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 ...... #f
43d0: 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 ;; itemsdat 5
43e0: 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 ...... #f
43f0: 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 ;; spare - us
4400: 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 ed for item-path
4410: 0a 09 09 09 09 09 20 20 20 20 20 29 29 29 0a 09 ...... )))..
4420: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 (for-each ..
4430: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 (lambda (wa
4440: 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 69 iton).. (i
4450: 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e f (and waiton (n
4460: 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f ot (member waito
4470: 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a n test-names))).
4480: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 .. (begin...
4490: 20 20 20 28 73 65 74 21 20 72 65 71 75 69 72 65 (set! require
44a0: 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 d-tests (cons wa
44b0: 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 iton required-te
44c0: 73 74 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 sts))... (se
44d0: 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 t! test-names (c
44e0: 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ons waiton test-
44f0: 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 names))))) ;; wa
4500: 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 s an append, now
4510: 20 61 20 63 6f 6e 73 0a 09 20 20 20 20 20 77 61 a cons.. wa
4520: 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 itons).. (let
4530: 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c ((remtests (del
4540: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
4550: 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 append waitons t
4560: 61 6c 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 al)))).. (i
4570: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 f (not (null? re
4580: 6d 74 65 73 74 73 29 29 0a 09 09 20 20 28 6c 6f mtests))... (lo
4590: 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 op (car remtests
45a0: 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 )(cdr remtests))
45b0: 29 29 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 ))))).. (if (
45c0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 not (null? requi
45d0: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 28 64 65 red-tests))..(de
45e0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
45f0: 20 22 41 64 64 69 6e 67 20 22 20 72 65 71 75 69 "Adding " requi
4600: 72 65 64 2d 74 65 73 74 73 20 22 20 74 6f 20 74 red-tests " to t
4610: 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 29 0a he run queue")).
4620: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 ;; NOTE: the
4630: 73 65 20 61 72 65 20 61 6c 6c 20 70 61 72 65 6e se are all paren
4640: 74 20 74 65 73 74 73 2c 20 69 74 65 6d 73 20 61 t tests, items a
4650: 72 65 20 6e 6f 74 20 65 78 70 61 6e 64 65 64 20 re not expanded
4660: 79 65 74 2e 0a 20 20 20 20 28 64 65 62 75 67 3a yet.. (debug:
4670: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 print-info 4 "te
4680: 73 74 2d 72 65 63 6f 72 64 73 3d 22 20 28 68 61 st-records=" (ha
4690: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
46a0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 test-records)).
46b0: 20 20 20 28 6c 65 74 20 28 28 72 65 67 6c 65 6e (let ((reglen
46c0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
46d0: 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 75 configdat "setu
46e0: 70 22 20 22 72 75 6e 71 75 65 75 65 22 29 29 29 p" "runqueue")))
46f0: 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c . (if (> (l
4700: 65 6e 67 74 68 20 28 68 61 73 68 2d 74 61 62 6c ength (hash-tabl
4710: 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f e-keys test-reco
4720: 72 64 73 29 29 20 30 29 0a 09 20 20 28 6c 65 74 rds)) 0).. (let
4730: 2a 20 28 28 6b 65 65 70 2d 67 6f 69 6e 67 20 20 * ((keep-going
4740: 20 20 20 20 20 20 23 74 29 0a 09 09 20 28 72 75 #t)... (ru
4750: 6e 2d 71 75 65 75 65 2d 72 65 74 72 69 65 73 20 n-queue-retries
4760: 35 29 0a 09 09 20 28 74 68 31 20 20 20 20 20 20 5)... (th1
4770: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 (make-thread (
4780: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 20 lambda ()......
4790: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
47a0: 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 20 20 20 tions......
47b0: 65 78 6e 0a 09 09 09 09 09 20 20 20 20 20 28 62 exn...... (b
47c0: 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 20 20 egin......
47d0: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
47e0: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
47f0: 72 2d 70 6f 72 74 29 29 0a 09 09 09 09 09 20 20 r-port))......
4800: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4810: 74 20 30 20 22 45 52 52 4f 52 3a 20 66 61 69 6c t 0 "ERROR: fail
4820: 75 72 65 20 69 6e 20 72 75 6e 73 3a 72 75 6e 2d ure in runs:run-
4830: 74 65 73 74 73 2d 71 75 65 75 65 20 74 68 72 65 tests-queue thre
4840: 61 64 2c 20 65 72 72 6f 72 3a 20 22 20 28 28 63 ad, error: " ((c
4850: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
4860: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
4870: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
4880: 09 09 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ..... (if
4890: 28 3e 20 72 75 6e 2d 71 75 65 75 65 2d 72 65 74 (> run-queue-ret
48a0: 72 69 65 73 20 30 29 0a 09 09 09 09 09 09 20 20 ries 0).......
48b0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 20 20 (begin.......
48c0: 20 20 20 28 73 65 74 21 20 72 75 6e 2d 71 75 65 (set! run-que
48d0: 75 65 2d 72 65 74 72 69 65 73 20 28 2d 20 72 75 ue-retries (- ru
48e0: 6e 2d 71 75 65 75 65 2d 72 65 74 72 69 65 73 20 n-queue-retries
48f0: 31 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 1))....... (
4900: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
4910: 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e ueue run-id runn
4920: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ame test-records
4930: 20 6b 65 79 76 61 6c 73 20 66 6c 61 67 73 20 74 keyvals flags t
4940: 65 73 74 2d 70 61 74 74 73 20 72 65 71 75 69 72 est-patts requir
4950: 65 64 2d 74 65 73 74 73 20 28 61 6e 79 2d 3e 6e ed-tests (any->n
4960: 75 6d 62 65 72 20 72 65 67 6c 65 6e 29 20 61 6c umber reglen) al
4970: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
4980: 20 61 72 65 61 2d 64 61 74 29 29 29 29 0a 09 09 area-dat))))...
4990: 09 09 09 20 20 20 20 20 28 72 75 6e 73 3a 72 75 ... (runs:ru
49a0: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
49b0: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
49c0: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
49d0: 73 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 s flags test-pat
49e0: 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ts required-test
49f0: 73 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 72 s (any->number r
4a00: 65 67 6c 65 6e 29 20 61 6c 6c 2d 74 65 73 74 73 eglen) all-tests
4a10: 2d 72 65 67 69 73 74 72 79 20 61 72 65 61 2d 64 -registry area-d
4a20: 61 74 29 29 29 0a 09 09 09 09 09 20 20 22 72 75 at)))...... "ru
4a30: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 ns:run-tests-que
4a40: 75 65 22 29 29 0a 09 09 20 28 74 68 32 20 20 20 ue"))... (th2
4a50: 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 (make-threa
4a60: 64 20 28 6c 61 6d 62 64 61 20 28 29 09 09 09 09 d (lambda ()....
4a70: 20 20 20 20 0a 09 09 09 09 09 20 20 20 20 3b 3b ...... ;;
4a80: 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d (rmt:find-and-m
4a90: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 2d 61 ark-incomplete-a
4aa0: 6c 6c 2d 72 75 6e 73 29 29 29 29 29 20 43 41 4e ll-runs))))) CAN
4ab0: 27 54 20 49 4e 54 45 52 52 55 50 54 20 49 54 20 'T INTERRUPT IT
4ac0: 2e 2e 2e 0a 09 09 09 09 09 20 20 20 20 28 6c 65 ......... (le
4ad0: 74 20 28 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 t ((run-ids (rmt
4ae0: 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 :get-all-run-ids
4af0: 20 61 72 65 61 2d 64 61 74 29 29 29 0a 09 09 09 area-dat)))....
4b00: 09 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 .. (for-eac
4b10: 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 h (lambda (run-i
4b20: 64 29 0a 09 09 09 09 09 09 09 20 20 28 69 66 20 d)........ (if
4b30: 6b 65 65 70 2d 67 6f 69 6e 67 0a 09 09 09 09 09 keep-going......
4b40: 09 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d .. (handle-
4b50: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 exceptions......
4b60: 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 09 .. exn....
4b70: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
4b80: 67 3a 70 72 69 6e 74 20 30 20 22 65 72 72 6f 72 g:print 0 "error
4b90: 20 69 6e 20 63 61 6c 6c 69 6e 67 20 66 69 6e 64 in calling find
4ba0: 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 -and-mark-incomp
4bb0: 6c 65 74 65 20 66 6f 72 20 72 75 6e 2d 69 64 20 lete for run-id
4bc0: 22 20 72 75 6e 2d 69 64 29 0a 09 09 09 09 09 09 " run-id).......
4bd0: 09 20 20 20 20 20 20 20 28 72 6d 74 3a 66 69 6e . (rmt:fin
4be0: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
4bf0: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 23 66 20 plete run-id #f
4c00: 61 72 65 61 2d 64 61 74 29 29 29 29 20 3b 3b 20 area-dat)))) ;;
4c10: 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 29 0a ovr-deadtime))).
4c20: 09 09 09 09 09 09 09 72 75 6e 2d 69 64 73 29 29 .......run-ids))
4c30: 29 0a 09 09 09 09 09 20 20 22 72 75 6e 73 3a 20 )...... "runs:
4c40: 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 73 mark-incompletes
4c50: 22 29 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 "))).. (threa
4c60: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 d-start! th1)..
4c70: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
4c80: 21 20 74 68 32 29 0a 09 20 20 20 20 28 74 68 72 ! th2).. (thr
4c90: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 09 ead-join! th1)..
4ca0: 20 20 20 20 28 73 65 74 21 20 6b 65 65 70 2d 67 (set! keep-g
4cb0: 6f 69 6e 67 20 23 66 29 0a 09 20 20 20 20 28 74 oing #f).. (t
4cc0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 hread-join! th2)
4cd0: 0a 09 20 20 20 20 3b 3b 20 69 66 20 72 75 6e 2d .. ;; if run-
4ce0: 63 6f 75 6e 74 20 3e 20 30 20 63 61 6c 6c 2c 20 count > 0 call,
4cf0: 73 65 74 20 2d 70 72 65 63 6c 65 61 6e 20 61 6e set -preclean an
4d00: 64 20 2d 72 65 72 75 6e 20 53 54 55 43 4b 2f 44 d -rerun STUCK/D
4d10: 45 41 44 0a 09 20 20 20 20 28 69 66 20 28 3e 20 EAD.. (if (>
4d20: 72 75 6e 2d 63 6f 75 6e 74 20 30 29 0a 09 09 28 run-count 0)...(
4d30: 62 65 67 69 6e 0a 09 09 20 20 28 69 66 20 28 6e begin... (if (n
4d40: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
4d50: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
4d60: 20 22 2d 70 72 65 63 6c 65 61 6e 22 20 23 66 29 "-preclean" #f)
4d70: 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 2d )... (hash-
4d80: 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 table-set! flags
4d90: 20 22 2d 70 72 65 63 6c 65 61 6e 22 20 23 74 29 "-preclean" #t)
4da0: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 )... (if (not (
4db0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4dc0: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 efault flags "-r
4dd0: 65 72 75 6e 22 20 23 66 29 29 0a 09 09 20 20 20 erun" #f))...
4de0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
4df0: 65 74 21 20 66 6c 61 67 73 20 22 2d 72 65 72 75 et! flags "-reru
4e00: 6e 22 20 22 53 54 55 43 4b 2f 44 45 41 44 2c 6e n" "STUCK/DEAD,n
4e10: 2f 61 2c 5a 45 52 4f 5f 49 54 45 4d 53 22 29 29 /a,ZERO_ITEMS"))
4e20: 0a 09 09 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 ... (runs:run-t
4e30: 65 73 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e ests target runn
4e40: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 ame test-patts u
4e50: 73 65 72 20 66 6c 61 67 73 20 61 72 65 61 2d 64 ser flags area-d
4e60: 61 74 20 72 75 6e 2d 63 6f 75 6e 74 3a 20 28 2d at run-count: (-
4e70: 20 72 75 6e 2d 63 6f 75 6e 74 20 31 29 29 29 29 run-count 1))))
4e80: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
4e90: 74 2d 69 6e 66 6f 20 30 20 22 4e 6f 20 74 65 73 t-info 0 "No tes
4ea0: 74 73 20 74 6f 20 72 75 6e 22 29 29 29 0a 20 20 ts to run"))).
4eb0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4ec0: 6e 66 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 nfo 4 "All done
4ed0: 62 79 20 68 65 72 65 22 29 0a 20 20 20 20 28 72 by here"). (r
4ee0: 6d 74 3a 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 mt:tasks-set-sta
4ef0: 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b te-given-param-k
4f00: 65 79 20 74 61 73 6b 2d 6b 65 79 20 22 64 6f 6e ey task-key "don
4f10: 65 22 20 61 72 65 61 2d 64 61 74 29 0a 20 20 20 e" area-dat).
4f20: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e ;; (sqlite3:fin
4f30: 61 6c 69 7a 65 21 20 74 61 73 6b 73 2d 64 62 29 alize! tasks-db)
4f40: 0a 20 20 20 20 29 29 0a 0a 0a 3b 3b 20 6c 6f 6f . ))...;; loo
4f50: 70 20 6c 6f 67 69 63 2e 20 54 68 65 73 65 20 61 p logic. These a
4f60: 72 65 20 75 73 65 64 20 69 6e 20 72 75 6e 73 3a re used in runs:
4f70: 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 run-tests-queue
4f80: 74 6f 20 6d 61 6b 65 20 69 74 20 61 20 62 69 74 to make it a bit
4f90: 20 6d 6f 72 65 20 72 65 61 64 61 62 6c 65 2e 0a more readable..
4fa0: 3b 3b 0a 3b 3b 20 49 66 20 72 65 67 20 6e 6f 74 ;;.;; If reg not
4fb0: 20 66 75 6c 6c 20 61 6e 64 20 68 61 76 65 20 69 full and have i
4fc0: 74 65 6d 73 20 69 6e 20 74 61 6c 20 74 68 65 6e tems in tal then
4fd0: 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 72 20 loop with (car
4fe0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
4ff0: 67 20 72 65 72 75 6e 73 0a 3b 3b 20 49 66 20 72 g reruns.;; If r
5000: 65 67 20 69 73 20 66 75 6c 6c 20 28 69 2e 65 2e eg is full (i.e.
5010: 20 6c 65 6e 67 74 68 20 3e 3d 20 6e 0a 3b 3b 20 length >= n.;;
5020: 20 20 6c 6f 6f 70 20 77 69 74 68 20 28 63 61 72 loop with (car
5030: 20 72 65 67 29 20 74 61 6c 20 28 63 64 72 20 72 reg) tal (cdr r
5040: 65 67 29 20 72 65 72 75 6e 73 0a 3b 3b 20 49 66 eg) reruns.;; If
5050: 20 74 61 6c 20 69 73 20 65 6d 70 74 79 0a 3b 3b tal is empty.;;
5060: 20 20 20 62 75 74 20 68 61 76 65 20 69 74 65 6d but have item
5070: 73 20 69 6e 20 72 65 67 3b 20 6c 6f 6f 70 20 77 s in reg; loop w
5080: 69 74 68 20 28 63 61 72 20 72 65 67 29 28 63 64 ith (car reg)(cd
5090: 72 20 72 65 67 29 20 27 28 29 20 72 65 72 75 6e r reg) '() rerun
50a0: 73 0a 3b 3b 20 20 20 49 66 20 72 65 67 20 69 73 s.;; If reg is
50b0: 20 65 6d 70 74 79 20 3d 3e 20 61 6c 6c 20 64 6f empty => all do
50c0: 6e 65 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ne..(define (run
50d0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 s:queue-next-hed
50e0: 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 tal reg n regfu
50f0: 6c 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c ll). (if regful
5100: 6c 0a 20 20 20 20 20 20 28 63 61 72 20 72 65 67 l. (car reg
5110: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c ). (if (nul
5120: 6c 3f 20 74 61 6c 29 20 3b 3b 20 74 61 6c 20 69 l? tal) ;; tal i
5130: 73 20 75 73 65 64 20 75 70 2c 20 70 6f 70 20 66 s used up, pop f
5140: 72 6f 6d 20 72 65 67 0a 09 20 20 28 63 61 72 20 rom reg.. (car
5150: 72 65 67 29 0a 09 20 20 28 63 61 72 20 74 61 6c reg).. (car tal
5160: 29 29 29 29 0a 0a 3b 3b 20 20 20 28 63 6f 6e 64 ))))..;; (cond
5170: 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 72 65 67 .;; ((and reg
5180: 66 75 6c 6c 20 28 6e 75 6c 6c 3f 20 72 65 67 29 full (null? reg)
5190: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
51a0: 29 29 20 20 20 20 20 20 28 63 61 72 20 74 61 6c )) (car tal
51b0: 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 20 72 )).;; ((and r
51c0: 65 67 66 75 6c 6c 20 28 6e 6f 74 20 28 6e 75 6c egfull (not (nul
51d0: 6c 3f 20 72 65 67 29 29 29 20 20 20 20 20 20 20 l? reg)))
51e0: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 72 (car r
51f0: 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 61 6e 64 eg)).;; ((and
5200: 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c 29 28 6e (not regfull)(n
5210: 75 6c 6c 3f 20 74 61 6c 29 28 6e 6f 74 20 28 6e ull? tal)(not (n
5220: 75 6c 6c 3f 20 72 65 67 29 29 29 20 28 63 61 72 ull? reg))) (car
5230: 20 72 65 67 29 29 0a 3b 3b 20 20 20 20 28 28 61 reg)).;; ((a
5240: 6e 64 20 28 6e 6f 74 20 72 65 67 66 75 6c 6c 29 nd (not regfull)
5250: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
5260: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 28 63 )) (c
5270: 61 72 20 74 61 6c 29 29 0a 3b 3b 20 20 20 20 28 ar tal)).;; (
5280: 65 6c 73 65 0a 3b 3b 20 20 20 20 20 28 64 65 62 else.;; (deb
5290: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
52a0: 52 3a 20 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 R: runs:queue-ne
52b0: 78 74 2d 68 65 64 2c 20 74 61 6c 3d 22 20 74 61 xt-hed, tal=" ta
52c0: 6c 20 22 2c 20 72 65 67 3d 22 20 72 65 67 20 22 l ", reg=" reg "
52d0: 2c 20 6e 3d 22 20 6e 20 22 2c 20 72 65 67 66 75 , n=" n ", regfu
52e0: 6c 6c 3d 22 20 72 65 67 66 75 6c 6c 29 0a 3b 3b ll=" regfull).;;
52f0: 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 #f)))..(def
5300: 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ine (runs:queue-
5310: 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 next-tal tal reg
5320: 20 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 28 69 n regfull). (i
5330: 66 20 72 65 67 66 75 6c 6c 0a 20 20 20 20 20 20 f regfull.
5340: 74 61 6c 0a 20 20 20 20 20 20 28 69 66 20 28 6e tal. (if (n
5350: 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 6d 75 73 ull? tal) ;; mus
5360: 74 20 74 72 61 6e 73 66 65 72 20 66 72 6f 6d 20 t transfer from
5370: 72 65 67 0a 09 20 20 28 63 64 72 20 72 65 67 29 reg.. (cdr reg)
5380: 0a 09 20 20 28 63 64 72 20 74 61 6c 29 29 29 29 .. (cdr tal))))
5390: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
53a0: 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 queue-next-reg t
53b0: 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c 6c al reg n regfull
53c0: 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c 6c 0a ). (if regfull.
53d0: 20 20 20 20 20 20 28 63 64 72 20 72 65 67 29 0a (cdr reg).
53e0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
53f0: 20 74 61 6c 29 20 3b 3b 20 69 66 20 74 61 6c 20 tal) ;; if tal
5400: 69 73 20 6e 75 6c 6c 20 61 6e 64 20 72 65 67 20 is null and reg
5410: 6e 6f 74 20 66 75 6c 6c 20 74 68 65 6e 20 27 28 not full then '(
5420: 29 20 61 73 20 72 65 67 20 63 6f 6e 74 65 6e 74 ) as reg content
5430: 73 20 6d 6f 76 65 64 20 74 6f 20 74 61 6c 0a 09 s moved to tal..
5440: 20 20 27 28 29 0a 09 20 20 72 65 67 29 29 29 0a '().. reg))).
5450: 0a 28 64 65 66 69 6e 65 20 72 75 6e 73 3a 6e 6f .(define runs:no
5460: 74 68 69 6e 67 2d 6c 65 66 74 2d 69 6e 2d 71 75 thing-left-in-qu
5470: 65 75 65 2d 63 6f 75 6e 74 20 30 29 0a 0a 28 64 eue-count 0)..(d
5480: 65 66 69 6e 65 20 28 72 75 6e 73 3a 65 78 70 61 efine (runs:expa
5490: 6e 64 2d 69 74 65 6d 73 20 68 65 64 20 74 61 6c nd-items hed tal
54a0: 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 67 66 reg reruns regf
54b0: 75 6c 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 67 72 ull newtal jobgr
54c0: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
54d0: 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 nt-jobs run-id w
54e0: 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 aitons item-path
54f0: 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 72 testmode test-r
5500: 65 63 6f 72 64 20 63 61 6e 2d 72 75 6e 2d 6d 6f ecord can-run-mo
5510: 72 65 20 69 74 65 6d 73 20 72 75 6e 6e 61 6d 65 re items runname
5520: 20 74 63 6f 6e 66 69 67 20 72 65 67 6c 65 6e 20 tconfig reglen
5530: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 test-registry te
5540: 73 74 2d 72 65 63 6f 72 64 73 20 69 74 65 6d 6d st-records itemm
5550: 61 70 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 ap area-dat). (
5560: 6c 65 74 2a 20 28 28 6c 6f 6f 70 2d 6c 69 73 74 let* ((loop-list
5570: 20 20 20 20 20 20 20 28 6c 69 73 74 20 68 65 64 (list hed
5580: 20 74 61 6c 20 72 65 67 20 72 65 72 75 6e 73 29 tal reg reruns)
5590: 29 0a 09 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 ).. (prereqs-not
55a0: 2d 6d 65 74 20 28 72 6d 74 3a 67 65 74 2d 70 72 -met (rmt:get-pr
55b0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru
55c0: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
55d0: 6d 2d 70 61 74 68 20 61 72 65 61 2d 64 61 74 20 m-path area-dat
55e0: 69 74 65 6d 6d 61 70 3a 20 69 74 65 6d 6d 61 70 itemmap: itemmap
55f0: 29 29 0a 09 20 3b 3b 20 28 70 72 65 72 65 71 73 )).. ;; (prereqs
5600: 2d 6e 6f 74 2d 6d 65 74 20 28 6d 74 3a 6c 61 7a -not-met (mt:laz
5610: 79 2d 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f y-get-prereqs-no
5620: 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 t-met run-id wai
5630: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d tons item-path m
5640: 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 20 69 74 ode: testmode it
5650: 65 6d 6d 61 70 3a 20 69 74 65 6d 6d 61 70 29 29 emmap: itemmap))
5660: 0a 09 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 .. (fails
5670: 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 (runs:calc-f
5680: 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 ails prereqs-not
5690: 2d 6d 65 74 29 29 0a 09 20 28 70 72 65 72 65 71 -met)).. (prereq
56a0: 2d 66 61 69 6c 73 20 20 20 20 28 72 75 6e 73 3a -fails (runs:
56b0: 63 61 6c 63 2d 70 72 65 72 65 71 2d 66 61 69 6c calc-prereq-fail
56c0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
56d0: 29 29 0a 09 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 )).. (non-comple
56e0: 74 65 64 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 ted (runs:calc
56f0: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
5700: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
5710: 0a 09 20 28 72 75 6e 6e 61 62 6c 65 73 20 20 20 .. (runnables
5720: 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 72 (runs:calc-r
5730: 75 6e 6e 61 62 6c 65 20 70 72 65 72 65 71 73 2d unnable prereqs-
5740: 6e 6f 74 2d 6d 65 74 29 29 29 0a 20 20 20 20 28 not-met))). (
5750: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5760: 20 34 20 22 53 54 41 52 54 20 4f 46 20 49 4e 4e 4 "START OF INN
5770: 45 52 20 43 4f 4e 44 20 23 32 20 22 0a 09 09 20 ER COND #2 "...
5780: 20 20 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e "\n can-run
5790: 2d 6d 6f 72 65 3a 20 20 20 20 22 20 63 61 6e 2d -more: " can-
57a0: 72 75 6e 2d 6d 6f 72 65 0a 09 09 20 20 20 20 20 run-more...
57b0: 20 22 5c 6e 20 74 65 73 74 6e 61 6d 65 3a 20 20 "\n testname:
57c0: 20 20 20 20 20 20 22 20 68 65 64 0a 09 09 20 20 " hed...
57d0: 20 20 20 20 22 5c 6e 20 70 72 65 72 65 71 73 2d "\n prereqs-
57e0: 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 72 75 6e 73 not-met: " (runs
57f0: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 :pretty-string p
5800: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
5810: 09 09 20 20 20 20 20 20 22 5c 6e 20 6e 6f 6e 2d .. "\n non-
5820: 63 6f 6d 70 6c 65 74 65 64 3a 20 20 20 22 20 28 completed: " (
5830: 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 runs:pretty-stri
5840: 6e 67 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 ng non-completed
5850: 29 20 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 70 ) ... "\n p
5860: 72 65 72 65 71 2d 66 61 69 6c 73 3a 20 20 20 20 rereq-fails:
5870: 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 " (runs:pretty-s
5880: 74 72 69 6e 67 20 70 72 65 72 65 71 2d 66 61 69 tring prereq-fai
5890: 6c 73 29 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 ls)... "\n
58a0: 66 61 69 6c 73 3a 20 20 20 20 20 20 20 20 20 20 fails:
58b0: 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d " (runs:pretty-
58c0: 73 74 72 69 6e 67 20 66 61 69 6c 73 29 0a 09 09 string fails)...
58d0: 20 20 20 20 20 20 22 5c 6e 20 74 65 73 74 6d 6f "\n testmo
58e0: 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 73 de: " tes
58f0: 74 6d 6f 64 65 0a 09 09 20 20 20 20 20 20 22 5c tmode... "\
5900: 6e 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 n (member 'tople
5910: 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 3a 20 22 vel testmode): "
5920: 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 (member 'toplev
5930: 65 6c 20 74 65 73 74 6d 6f 64 65 29 0a 09 09 20 el testmode)...
5940: 20 20 20 20 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 "\n (null?
5950: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 3a 20 non-completed):
5960: 20 20 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d " (null? non-
5970: 63 6f 6d 70 6c 65 74 65 64 29 0a 09 09 20 20 20 completed)...
5980: 20 20 20 22 5c 6e 20 72 65 72 75 6e 73 3a 20 20 "\n reruns:
5990: 20 20 20 20 20 20 20 20 22 20 72 65 72 75 6e 73 " reruns
59a0: 0a 09 09 20 20 20 20 20 20 22 5c 6e 20 69 74 65 ... "\n ite
59b0: 6d 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 ms: "
59c0: 69 74 65 6d 73 0a 09 09 20 20 20 20 20 20 22 5c items... "\
59d0: 6e 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 n can-run-more:
59e0: 20 20 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 " can-run-mor
59f0: 65 29 0a 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 e).. (cond.
5a00: 20 20 20 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 ;; all prereq
5a10: 73 20 6d 65 74 2c 20 66 69 72 65 20 6f 66 66 20 s met, fire off
5a20: 74 68 65 20 74 65 73 74 0a 20 20 20 20 20 3b 3b the test. ;;
5a30: 20 6f 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 or, if it is a
5a40: 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 'toplevel test a
5a50: 6e 64 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e nd all prereqs n
5a60: 6f 74 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c ot met are COMPL
5a70: 45 54 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 ETED then launch
5a80: 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f .. ((and (no
5a90: 74 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 t (member 'tople
5aa0: 76 65 6c 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 vel testmode))..
5ab0: 20 20 20 28 6d 65 6d 62 65 72 20 28 68 61 73 68 (member (hash
5ac0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5ad0: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 lt test-registry
5ae0: 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 (db:test-make-f
5af0: 75 6c 6c 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 ull-name hed ite
5b00: 6d 2d 70 61 74 68 29 20 27 6e 2f 61 29 0a 09 09 m-path) 'n/a)...
5b10: 20 20 20 27 28 44 4f 4e 4f 54 52 55 4e 20 72 65 '(DONOTRUN re
5b20: 6d 6f 76 65 64 20 43 41 4e 4e 4f 54 52 55 4e 29 moved CANNOTRUN)
5b30: 29 29 20 3b 3b 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 )) ;; *common:ca
5b40: 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 2d 73 79 nt-run-states-sy
5b50: 6d 2a 29 20 3b 3b 20 27 28 43 4f 4d 50 4c 45 54 m*) ;; '(COMPLET
5b60: 45 44 20 4b 49 4c 4c 45 44 20 57 41 49 56 45 44 ED KILLED WAIVED
5b70: 20 55 4e 4b 4e 4f 57 4e 20 49 4e 43 4f 4d 50 4c UNKNOWN INCOMPL
5b80: 45 54 45 29 29 20 3b 3b 20 74 72 79 20 74 6f 20 ETE)) ;; try to
5b90: 63 61 74 63 68 20 72 65 70 65 61 74 20 70 72 6f catch repeat pro
5ba0: 63 65 73 73 69 6e 67 20 6f 66 20 43 4f 4d 50 4c cessing of COMPL
5bb0: 45 54 45 44 20 74 65 73 74 73 20 68 65 72 65 0a ETED tests here.
5bc0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
5bd0: 6e 74 2d 69 6e 66 6f 20 31 20 22 54 65 73 74 20 nt-info 1 "Test
5be0: 22 20 68 65 64 20 22 20 73 65 74 20 74 6f 20 5c " hed " set to \
5bf0: 22 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 "" (hash-table-r
5c00: 65 66 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ef test-registry
5c10: 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 (db:test-make-f
5c20: 75 6c 6c 2d 6e 61 6d 65 20 68 65 64 20 69 74 65 ull-name hed ite
5c30: 6d 2d 70 61 74 68 29 29 20 22 5c 22 2e 20 52 65 m-path)) "\". Re
5c40: 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 moving it from t
5c50: 68 65 20 71 75 65 75 65 22 29 0a 20 20 20 20 20 he queue").
5c60: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e (if (or (not (n
5c70: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 ull? tal))..
5c80: 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 (not (null? re
5c90: 67 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 72 g))).. (list (r
5ca0: 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 uns:queue-next-h
5cb0: 65 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 ed tal reg regle
5cc0: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 n regfull)...(ru
5cd0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 ns:queue-next-ta
5ce0: 6c 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e l tal reg reglen
5cf0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e regfull)...(run
5d00: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
5d10: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
5d20: 72 65 67 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e regfull)...rerun
5d30: 73 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 s).. (begin..
5d40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5d50: 6e 66 6f 20 30 20 22 4e 6f 74 68 69 6e 67 20 6c nfo 0 "Nothing l
5d60: 65 66 74 20 69 6e 20 74 68 65 20 71 75 65 75 65 eft in the queue
5d70: 21 22 29 0a 09 20 20 20 20 3b 3b 20 49 66 20 67 !").. ;; If g
5d80: 65 74 20 68 65 72 65 20 74 77 69 63 65 20 74 68 et here twice th
5d90: 65 6e 20 77 65 20 6b 6e 6f 77 20 77 65 27 76 65 en we know we've
5da0: 20 74 72 69 65 64 20 74 6f 20 65 78 70 61 6e 64 tried to expand
5db0: 20 61 6c 6c 20 69 74 65 6d 73 0a 09 20 20 20 20 all items..
5dc0: 3b 3b 20 73 69 6e 63 65 20 74 68 65 72 65 20 6d ;; since there m
5dd0: 75 73 74 20 62 65 20 61 20 6c 6f 67 69 63 20 69 ust be a logic i
5de0: 73 73 75 65 20 77 69 74 68 20 74 68 65 20 68 61 ssue with the ha
5df0: 6e 64 6c 69 6e 67 20 6f 66 20 6c 6f 6f 70 73 20 ndling of loops
5e00: 69 6e 20 74 68 65 20 0a 09 20 20 20 20 3b 3b 20 in the .. ;;
5e10: 69 74 65 6d 73 20 65 78 70 61 6e 64 20 70 68 61 items expand pha
5e20: 73 65 20 77 65 20 77 69 6c 6c 20 62 72 75 74 65 se we will brute
5e30: 20 66 6f 72 63 65 20 61 6e 20 65 78 69 74 20 68 force an exit h
5e40: 65 72 65 2e 0a 09 20 20 20 20 28 69 66 20 28 3e ere... (if (>
5e50: 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 runs:nothing-le
5e60: 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e ft-in-queue-coun
5e70: 74 20 32 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 t 2)...(begin...
5e80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5e90: 20 22 57 41 52 4e 49 4e 47 3a 20 74 68 69 73 20 "WARNING: this
5ea0: 63 6f 6e 64 69 74 69 6f 6e 20 69 73 20 74 72 69 condition is tri
5eb0: 67 67 65 72 65 64 20 77 68 65 6e 20 74 68 65 72 ggered when ther
5ec0: 65 20 77 65 72 65 20 6e 6f 20 69 74 65 6d 73 20 e were no items
5ed0: 74 6f 20 65 78 70 61 6e 64 20 61 6e 64 20 6e 6f to expand and no
5ee0: 74 68 69 6e 67 20 74 6f 20 72 75 6e 2e 20 50 6c thing to run. Pl
5ef0: 65 61 73 65 20 63 68 65 63 6b 20 79 6f 75 72 20 ease check your
5f00: 72 75 6e 20 66 6f 72 20 63 6f 6d 70 6c 65 74 65 run for complete
5f10: 6e 65 73 73 22 29 0a 09 09 20 20 28 65 78 69 74 ness")... (exit
5f20: 20 30 29 29 0a 09 09 28 73 65 74 21 20 72 75 6e 0))...(set! run
5f30: 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 66 74 2d 69 s:nothing-left-i
5f40: 6e 2d 71 75 65 75 65 2d 63 6f 75 6e 74 20 28 2b n-queue-count (+
5f50: 20 72 75 6e 73 3a 6e 6f 74 68 69 6e 67 2d 6c 65 runs:nothing-le
5f60: 66 74 2d 69 6e 2d 71 75 65 75 65 2d 63 6f 75 6e ft-in-queue-coun
5f70: 74 20 31 29 29 29 0a 09 20 20 20 20 23 66 29 29 t 1))).. #f))
5f80: 29 0a 0a 20 20 20 20 20 3b 3b 20 0a 20 20 20 20 ).. ;; .
5f90: 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 ((or (null? pre
5fa0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 20 reqs-not-met)..
5fb0: 20 28 61 6e 64 20 28 6d 65 6d 62 65 72 20 27 74 (and (member 't
5fc0: 6f 70 6c 65 76 65 6c 20 74 65 73 74 6d 6f 64 65 oplevel testmode
5fd0: 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f ).. (null?
5fe0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 non-completed))
5ff0: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
6000: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e rint-info 4 "run
6010: 73 3a 65 78 70 61 6e 64 2d 69 74 65 6d 73 3a 20 s:expand-items:
6020: 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 (or (null? prere
6030: 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 28 61 6e 64 qs-not-met) (and
6040: 20 28 6d 65 6d 62 65 72 20 27 74 6f 70 6c 65 76 (member 'toplev
6050: 65 6c 20 74 65 73 74 6d 6f 64 65 29 28 6e 75 6c el testmode)(nul
6060: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
6070: 29 29 29 22 29 0a 20 20 20 20 20 20 28 6c 65 74 )))"). (let
6080: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 ((test-name (te
6090: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
60a0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
60b0: 72 65 63 6f 72 64 29 29 29 0a 09 28 73 65 74 65 record)))..(sete
60c0: 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 nv "MT_TEST_NAME
60d0: 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 " test-name) ;;
60e0: 0a 09 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 ..(setenv "MT_RU
60f0: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
6100: 29 0a 09 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 )..(runs:set-meg
6110: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 atest-env-vars r
6120: 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 20 69 un-id area-dat i
6130: 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d nrunname: runnam
6140: 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 e) ;; these may
6150: 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 be needed by the
6160: 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 launching proce
6170: 73 73 0a 09 28 6c 65 74 20 28 28 69 74 65 6d 73 ss..(let ((items
6180: 2d 6c 69 73 74 20 28 69 74 65 6d 73 3a 67 65 74 -list (items:get
6190: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
61a0: 69 67 20 74 63 6f 6e 66 69 67 29 29 29 0a 09 20 ig tconfig)))..
61b0: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
61c0: 73 2d 6c 69 73 74 29 0a 09 20 20 20 20 20 20 28 s-list).. (
61d0: 62 65 67 69 6e 0a 09 09 28 69 66 20 28 6e 75 6c begin...(if (nul
61e0: 6c 3f 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 l? items-list)..
61f0: 09 20 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 . (let ((test
6200: 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
6210: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
6220: 2d 6e 61 6d 65 20 22 22 20 61 72 65 61 2d 64 61 -name "" area-da
6230: 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 t)))... (if
6240: 20 74 65 73 74 2d 69 64 20 28 6d 74 3a 74 65 73 test-id (mt:tes
6250: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
6260: 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
6270: 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 54 41 test-id "NOT_STA
6280: 52 54 45 44 22 20 22 5a 45 52 4f 5f 49 54 45 4d RTED" "ZERO_ITEM
6290: 53 22 20 22 46 61 69 6c 65 64 20 74 6f 20 72 75 S" "Failed to ru
62a0: 6e 20 64 75 65 20 74 6f 20 66 61 69 6c 65 64 20 n due to failed
62b0: 70 72 65 72 65 71 75 69 73 69 74 65 73 22 29 29 prerequisites"))
62c0: 29 29 0a 09 09 28 74 65 73 74 73 3a 74 65 73 74 ))...(tests:test
62d0: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 queue-set-items!
62e0: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 65 test-record ite
62f0: 6d 73 2d 6c 69 73 74 29 0a 09 09 28 6c 69 73 74 ms-list)...(list
6300: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
6310: 75 6e 73 29 29 0a 09 20 20 20 20 20 20 28 62 65 uns)).. (be
6320: 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 gin...(debug:pri
6330: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 nt 0 "ERROR: The
6340: 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 61 64 69 proc from readi
6350: 6e 67 20 74 68 65 20 69 74 65 6d 73 20 74 61 62 ng the items tab
6360: 6c 65 20 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 le did not yield
6370: 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 a list - please
6380: 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 report this")..
6390: 09 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 0a .(exit 1))))))..
63a0: 20 20 20 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c ((and (null
63b0: 3f 20 66 61 69 6c 73 29 0a 09 20 20 20 28 6e 75 ? fails).. (nu
63c0: 6c 6c 3f 20 70 72 65 72 65 71 2d 66 61 69 6c 73 ll? prereq-fails
63d0: 29 0a 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c ).. (not (null
63e0: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
63f0: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 )). (let* (
6400: 28 61 6c 6c 69 6e 71 75 65 75 65 20 28 6d 61 70 (allinqueue (map
6410: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 69 66 20 (lambda (x)(if
6420: 28 73 74 72 69 6e 67 3f 20 78 29 20 78 20 28 64 (string? x) x (d
6430: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
6440: 61 6d 65 20 78 29 29 29 0a 20 20 20 20 20 20 20 ame x))).
6450: 20 09 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 .. (append
6460: 20 6e 65 77 74 61 6c 20 72 65 72 75 6e 73 29 29 newtal reruns))
6470: 29 0a 09 20 20 20 20 20 3b 3b 20 70 72 65 72 65 ).. ;; prere
6480: 71 73 74 72 73 20 69 73 20 61 20 6c 69 73 74 20 qstrs is a list
6490: 6f 66 20 74 65 73 74 20 6e 61 6d 65 73 20 61 73 of test names as
64a0: 20 73 74 72 69 6e 67 73 20 74 68 61 74 20 61 72 strings that ar
64b0: 65 20 70 72 65 72 65 71 73 20 66 6f 72 20 68 65 e prereqs for he
64c0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 d. (
64d0: 70 72 65 72 65 71 73 74 72 73 20 28 64 65 6c 65 prereqstrs (dele
64e0: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 6d te-duplicates (m
64f0: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 69 ap (lambda (x)(i
6500: 66 20 28 73 74 72 69 6e 67 3f 20 78 29 20 78 20 f (string? x) x
6510: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
6520: 74 6e 61 6d 65 20 78 29 29 29 0a 09 09 09 09 09 tname x)))......
6530: 09 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 . prereqs-not-me
6540: 74 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 61 20 t))).. ;; a
6550: 70 72 65 72 65 71 20 74 68 61 74 20 69 73 20 6e prereq that is n
6560: 6f 74 20 66 6f 75 6e 64 20 69 6e 20 61 6c 6c 69 ot found in alli
6570: 6e 71 75 65 75 65 20 77 69 6c 6c 20 62 65 20 70 nqueue will be p
6580: 75 74 20 69 6e 20 74 68 65 20 6e 6f 74 69 6e 71 ut in the notinq
6590: 75 65 75 65 20 6c 69 73 74 0a 09 20 20 20 20 20 ueue list..
65a0: 3b 3b 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 ;; .
65b0: 20 3b 3b 20 28 6e 6f 74 69 6e 71 75 65 75 65 20 ;; (notinqueue
65c0: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
65d0: 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 (x).
65e0: 20 3b 3b 20 20 20 20 09 09 20 20 20 28 6e 6f 74 ;; .. (not
65f0: 20 28 6d 65 6d 62 65 72 20 78 20 61 6c 6c 69 6e (member x allin
6600: 71 75 65 75 65 29 29 29 0a 20 20 20 20 20 20 20 queue))).
6610: 20 20 20 20 20 20 3b 3b 20 20 20 20 09 09 20 70 ;; .. p
6620: 72 65 72 65 71 73 74 72 73 29 29 0a 09 20 20 20 rereqstrs))..
6630: 20 20 28 67 69 76 65 2d 75 70 20 20 20 20 23 66 (give-up #f
6640: 29 29 0a 0a 09 3b 3b 20 57 65 20 63 61 6e 20 67 ))...;; We can g
6650: 65 74 20 68 65 72 65 20 77 68 65 6e 20 61 20 70 et here when a p
6660: 72 65 72 65 71 20 68 61 73 20 6e 6f 74 20 62 65 rereq has not be
6670: 65 6e 20 72 75 6e 20 64 75 65 20 74 6f 20 2a 69 en run due to *i
6680: 74 2a 20 68 61 76 69 6e 67 20 61 20 70 72 65 72 t* having a prer
6690: 65 71 20 74 68 61 74 20 66 61 69 6c 65 64 2e 0a eq that failed..
66a0: 09 3b 3b 20 57 65 20 6e 65 65 64 20 74 6f 20 75 .;; We need to u
66b0: 73 65 20 74 68 69 73 20 74 6f 20 64 65 71 75 65 se this to deque
66c0: 75 65 20 74 68 69 73 20 69 74 65 6d 20 61 73 20 ue this item as
66d0: 43 41 4e 4e 4f 54 52 55 4e 0a 09 3b 3b 20 0a 09 CANNOTRUN..;; ..
66e0: 28 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 74 (if (member test
66f0: 6d 6f 64 65 20 27 28 74 6f 70 6c 65 76 65 6c 29 mode '(toplevel)
6700: 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ).. (for-each
6710: 20 28 6c 61 6d 62 64 61 20 28 70 72 65 72 65 71 (lambda (prereq
6720: 29 0a 09 09 09 28 69 66 20 28 65 71 3f 20 28 68 )....(if (eq? (h
6730: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
6740: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 fault test-regis
6750: 74 72 79 20 70 72 65 72 65 71 20 27 6a 75 73 74 try prereq 'just
6760: 66 69 6e 65 29 20 27 43 41 4e 4e 4f 54 52 55 4e fine) 'CANNOTRUN
6770: 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 67 ).... (set! g
6780: 69 76 65 2d 75 70 20 23 74 29 29 29 0a 09 09 20 ive-up #t)))...
6790: 20 20 20 20 20 70 72 65 72 65 71 73 74 72 73 29 prereqstrs)
67a0: 29 0a 0a 09 28 69 66 20 28 61 6e 64 20 67 69 76 )...(if (and giv
67b0: 65 2d 75 70 0a 09 09 20 28 6e 6f 74 20 28 61 6e e-up... (not (an
67c0: 64 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 28 6e 75 d (null? tal)(nu
67d0: 6c 6c 3f 20 72 65 67 29 29 29 29 0a 09 20 20 20 ll? reg))))..
67e0: 20 28 6c 65 74 20 28 28 74 72 69 6d 6d 65 64 2d (let ((trimmed-
67f0: 74 61 6c 20 28 6d 74 3a 64 69 73 63 61 72 64 2d tal (mt:discard-
6800: 62 6c 6f 63 6b 65 64 2d 74 65 73 74 73 20 72 75 blocked-tests ru
6810: 6e 2d 69 64 20 68 65 64 20 74 61 6c 20 74 65 73 n-id hed tal tes
6820: 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 09 20 20 t-records))...
6830: 28 74 72 69 6d 6d 65 64 2d 72 65 67 20 28 6d 74 (trimmed-reg (mt
6840: 3a 64 69 73 63 61 72 64 2d 62 6c 6f 63 6b 65 64 :discard-blocked
6850: 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 20 68 65 -tests run-id he
6860: 64 20 72 65 67 20 74 65 73 74 2d 72 65 63 6f 72 d reg test-recor
6870: 64 73 29 29 29 0a 09 20 20 20 20 20 20 28 64 65 ds))).. (de
6880: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 bug:print 1 "WAR
6890: 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 68 65 64 NING: test " hed
68a0: 20 22 20 68 61 73 20 64 69 73 63 61 72 64 65 64 " has discarded
68b0: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 2c 20 prerequisites,
68c0: 72 65 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d removing it from
68d0: 20 74 68 65 20 71 75 65 75 65 22 29 0a 0a 09 20 the queue")...
68e0: 20 20 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 (let ((test
68f0: 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
6900: 74 2d 69 64 20 72 75 6e 2d 69 64 20 68 65 64 20 t-id run-id hed
6910: 22 22 20 61 72 65 61 2d 64 61 74 29 29 29 0a 09 "" area-dat)))..
6920: 09 28 69 66 20 74 65 73 74 2d 69 64 20 28 6d 74 .(if test-id (mt
6930: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
6940: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
6950: 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 -id test-id "NOT
6960: 5f 53 54 41 52 54 45 44 22 20 22 50 52 45 51 5f _STARTED" "PREQ_
6970: 44 49 53 43 41 52 44 45 44 22 20 22 46 61 69 6c DISCARDED" "Fail
6980: 65 64 20 74 6f 20 72 75 6e 20 64 75 65 20 74 6f ed to run due to
6990: 20 64 69 73 63 61 72 64 65 64 20 70 72 65 72 65 discarded prere
69a0: 71 75 69 73 69 74 65 73 22 29 29 29 0a 09 20 20 quisites")))..
69b0: 20 20 20 20 0a 09 20 20 20 20 20 20 28 69 66 20 .. (if
69c0: 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 74 72 69 6d (and (null? trim
69d0: 6d 65 64 2d 74 61 6c 29 0a 09 09 20 20 20 20 20 med-tal)...
69e0: 20 20 28 6e 75 6c 6c 3f 20 74 72 69 6d 6d 65 64 (null? trimmed
69f0: 2d 72 65 67 29 29 0a 09 09 20 20 23 66 0a 09 09 -reg))... #f...
6a00: 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 (list (runs:qu
6a10: 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 72 69 eue-next-hed tri
6a20: 6d 6d 65 64 2d 74 61 6c 20 74 72 69 6d 6d 65 64 mmed-tal trimmed
6a30: 2d 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 09 28 72 75 6e 73 3a 71 75 ull)....(runs:qu
6a50: 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 72 69 eue-next-tal tri
6a60: 6d 6d 65 64 2d 74 61 6c 20 74 72 69 6d 6d 65 64 mmed-tal trimmed
6a70: 2d 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 -reg reglen regf
6a80: 75 6c 6c 29 0a 09 09 09 28 72 75 6e 73 3a 71 75 ull)....(runs:qu
6a90: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 72 69 eue-next-reg tri
6aa0: 6d 6d 65 64 2d 74 61 6c 20 74 72 69 6d 6d 65 64 mmed-tal trimmed
6ab0: 2d 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 -reg reglen regf
6ac0: 75 6c 6c 29 0a 09 09 09 72 65 72 75 6e 73 29 29 ull)....reruns))
6ad0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 ).. (list (
6ae0: 63 61 72 20 6e 65 77 74 61 6c 29 28 61 70 70 65 car newtal)(appe
6af0: 6e 64 20 28 63 64 72 20 6e 65 77 74 61 6c 29 20 nd (cdr newtal)
6b00: 72 65 67 29 20 27 28 29 20 72 65 72 75 6e 73 29 reg) '() reruns)
6b10: 29 29 29 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 ))).. ((and
6b20: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 20 (null? fails)..
6b30: 20 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 2d (null? prereq-
6b40: 66 61 69 6c 73 29 0a 09 20 20 20 28 6e 75 6c 6c fails).. (null
6b50: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
6b60: 29 0a 20 20 20 20 20 20 28 69 66 20 20 28 72 75 ). (if (ru
6b70: 6e 73 3a 63 61 6e 2d 6b 65 65 70 2d 72 75 6e 6e ns:can-keep-runn
6b80: 69 6e 67 3f 20 68 65 64 20 32 30 29 0a 09 20 20 ing? hed 20)..
6b90: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 72 75 6e (begin.. (run
6ba0: 73 3a 69 6e 63 2d 63 61 6e 74 2d 72 75 6e 2d 74 s:inc-cant-run-t
6bb0: 65 73 74 73 20 68 65 64 29 0a 09 20 20 20 20 28 ests hed).. (
6bc0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6bd0: 20 31 20 22 6e 6f 20 66 61 69 6c 73 20 69 6e 20 1 "no fails in
6be0: 70 72 65 72 65 71 75 69 73 69 74 65 73 20 66 6f prerequisites fo
6bf0: 72 20 22 20 68 65 64 20 22 20 62 75 74 20 61 6c r " hed " but al
6c00: 73 6f 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 2c so none running,
6c10: 20 6b 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 keeping " hed "
6c20: 20 66 6f 72 20 6e 6f 77 2e 20 54 72 79 20 63 6f for now. Try co
6c30: 75 6e 74 3a 20 22 20 28 68 61 73 68 2d 74 61 62 unt: " (hash-tab
6c40: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
6c50: 73 65 65 6e 2d 63 61 6e 74 2d 72 75 6e 2d 74 65 seen-cant-run-te
6c60: 73 74 73 2a 20 68 65 64 20 30 29 29 0a 09 20 20 sts* hed 0))..
6c70: 20 20 3b 3b 20 67 65 74 74 69 6e 67 20 68 65 72 ;; getting her
6c80: 65 20 6c 69 6b 65 6c 79 20 6d 65 61 6e 73 20 74 e likely means t
6c90: 68 65 20 73 79 73 74 65 6d 20 69 73 20 77 61 79 he system is way
6ca0: 20 6f 76 65 72 6c 6f 61 64 65 64 2c 20 6b 69 6c overloaded, kil
6cb0: 6c 20 61 20 66 75 6c 6c 20 6d 69 6e 75 74 65 20 l a full minute
6cc0: 62 65 66 6f 72 65 20 63 6f 6e 74 69 6e 75 69 6e before continuin
6cd0: 67 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 g.. (thread-s
6ce0: 6c 65 65 70 21 20 36 30 29 0a 09 20 20 20 20 3b leep! 60).. ;
6cf0: 3b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 63 6f ; num-retries co
6d00: 64 65 20 77 61 73 20 68 65 72 65 0a 09 20 20 20 de was here..
6d10: 20 3b 3b 20 77 65 20 75 73 65 20 74 68 69 73 20 ;; we use this
6d20: 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 6d opportunity to m
6d30: 6f 76 65 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 ove contents of
6d40: 72 65 67 20 74 6f 20 74 61 6c 0a 09 20 20 20 20 reg to tal..
6d50: 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 (list (car newta
6d60: 6c 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e l)(append (cdr n
6d70: 65 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 ewtal) reg) '()
6d80: 72 65 72 75 6e 73 29 29 20 3b 3b 20 61 6e 20 69 reruns)) ;; an i
6d90: 73 73 75 65 20 77 69 74 68 20 70 72 65 72 65 71 ssue with prereq
6da0: 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 s not yet met?..
6db0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d
6dc0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6dd0: 31 20 22 6e 6f 20 66 61 69 6c 73 20 69 6e 20 70 1 "no fails in p
6de0: 72 65 72 65 71 75 69 73 69 74 65 73 20 66 6f 72 rerequisites for
6df0: 20 22 20 68 65 64 20 22 20 62 75 74 20 6e 6f 74 " hed " but not
6e00: 68 69 6e 67 20 73 65 65 6e 20 72 75 6e 6e 69 6e hing seen runnin
6e10: 67 20 69 6e 20 61 20 77 68 69 6c 65 2c 20 64 72 g in a while, dr
6e20: 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 68 65 opping test " he
6e30: 64 20 22 20 66 72 6f 6d 20 74 68 65 20 72 75 6e d " from the run
6e40: 20 71 75 65 75 65 22 29 0a 09 20 20 20 20 28 6c queue").. (l
6e50: 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 6d et ((test-id (rm
6e60: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
6e70: 6e 2d 69 64 20 68 65 64 20 22 22 20 61 72 65 61 n-id hed "" area
6e80: 2d 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 -dat))).. (
6e90: 69 66 20 74 65 73 74 2d 69 64 20 28 6d 74 3a 74 if test-id (mt:t
6ea0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
6eb0: 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 atus-by-id run-i
6ec0: 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 d test-id "NOT_S
6ed0: 54 41 52 54 45 44 22 20 22 54 49 4d 45 44 5f 4f TARTED" "TIMED_O
6ee0: 55 54 22 20 22 4e 6f 74 68 69 6e 67 20 73 65 65 UT" "Nothing see
6ef0: 6e 20 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 77 n running in a w
6f00: 68 69 6c 65 2e 22 29 29 29 0a 09 20 20 20 20 28 hile."))).. (
6f10: 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 75 65 list (runs:queue
6f20: 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 -next-hed tal re
6f30: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
6f40: 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 )... (runs:queu
6f50: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
6f60: 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c eg reglen regful
6f70: 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 65 l)... (runs:que
6f80: 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 ue-next-reg tal
6f90: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
6fa0: 6c 6c 29 0a 09 09 20 20 72 65 72 75 6e 73 29 29 ll)... reruns))
6fb0: 29 29 0a 0a 20 20 20 20 20 28 28 61 6e 64 20 0a )).. ((and .
6fc0: 20 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 (or (not
6fd0: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 0a 09 (null? fails))..
6fe0: 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 70 (not (null? p
6ff0: 72 65 72 65 71 2d 66 61 69 6c 73 29 29 29 0a 20 rereq-fails))).
7000: 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 27 6e (member 'n
7010: 6f 72 6d 61 6c 20 74 65 73 74 6d 6f 64 65 29 29 ormal testmode))
7020: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
7030: 69 6e 74 2d 69 6e 66 6f 20 31 20 22 74 65 73 74 int-info 1 "test
7040: 20 22 20 20 68 65 64 20 22 20 28 6d 6f 64 65 3d " hed " (mode=
7050: 22 20 74 65 73 74 6d 6f 64 65 20 22 29 20 68 61 " testmode ") ha
7060: 73 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 s failed prerequ
7070: 69 73 69 74 65 28 73 29 3b 20 22 0a 09 09 09 28 isite(s); "....(
7080: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7090: 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 se (map (lambda
70a0: 28 74 29 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 (t)(conc (db:tes
70b0: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
70c0: 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 ) ":" (db:test-g
70d0: 65 74 2d 73 74 61 74 65 20 74 29 22 2f 22 28 64 et-state t)"/"(d
70e0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
70f0: 73 20 74 29 29 29 20 66 61 69 6c 73 29 20 22 2c s t))) fails) ",
7100: 20 22 29 0a 09 09 09 22 2c 20 72 65 6d 6f 76 69 ")....", removi
7110: 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 6f ng it from to-do
7120: 20 6c 69 73 74 22 29 0a 20 20 20 20 20 20 28 6c list"). (l
7130: 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 6d et ((test-id (rm
7140: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
7150: 6e 2d 69 64 20 68 65 64 20 22 22 20 61 72 65 61 n-id hed "" area
7160: 2d 64 61 74 29 29 29 0a 09 28 69 66 20 74 65 73 -dat)))..(if tes
7170: 74 2d 69 64 0a 09 20 20 20 20 28 69 66 20 28 6e t-id.. (if (n
7180: 6f 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 ot (null? prereq
7190: 2d 66 61 69 6c 73 29 29 0a 09 09 28 6d 74 3a 74 -fails))...(mt:t
71a0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
71b0: 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 atus-by-id run-i
71c0: 64 20 74 65 73 74 2d 69 64 20 22 4e 4f 54 5f 53 d test-id "NOT_S
71d0: 54 41 52 54 45 44 22 20 22 50 52 45 51 5f 44 49 TARTED" "PREQ_DI
71e0: 53 43 41 52 44 45 44 22 20 22 46 61 69 6c 65 64 SCARDED" "Failed
71f0: 20 74 6f 20 72 75 6e 20 64 75 65 20 74 6f 20 70 to run due to p
7200: 72 69 6f 72 20 66 61 69 6c 65 64 20 70 72 65 72 rior failed prer
7210: 65 71 75 69 73 69 74 65 73 22 29 0a 09 09 28 6d equisites")...(m
7220: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
7230: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
7240: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 4e 4f n-id test-id "NO
7250: 54 5f 53 54 41 52 54 45 44 22 20 22 50 52 45 51 T_STARTED" "PREQ
7260: 5f 46 41 49 4c 22 20 20 20 20 20 20 22 46 61 69 _FAIL" "Fai
7270: 6c 65 64 20 74 6f 20 72 75 6e 20 64 75 65 20 74 led to run due t
7280: 6f 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 o failed prerequ
7290: 69 73 69 74 65 73 22 29 29 29 29 0a 20 20 20 20 isites")))).
72a0: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
72b0: 6e 75 6c 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 null? reg))(not
72c0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 (null? tal)))..
72d0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 68 61 (begin.. (ha
72e0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
72f0: 73 74 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 st-registry hed
7300: 27 43 41 4e 4e 4f 54 52 55 4e 29 0a 09 20 20 20 'CANNOTRUN)..
7310: 20 28 6c 69 73 74 20 28 72 75 6e 73 3a 71 75 65 (list (runs:que
7320: 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 ue-next-hed tal
7330: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
7340: 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 75 ll)... (runs:qu
7350: 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c eue-next-tal tal
7360: 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 reg reglen regf
7370: 75 6c 6c 29 0a 09 09 20 20 28 72 75 6e 73 3a 71 ull)... (runs:q
7380: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 74 61 ueue-next-reg ta
7390: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
73a0: 66 75 6c 6c 29 0a 09 09 20 20 28 63 6f 6e 73 20 full)... (cons
73b0: 68 65 64 20 72 65 72 75 6e 73 29 29 29 0a 09 20 hed reruns)))..
73c0: 20 23 66 29 29 20 3b 3b 20 23 66 20 66 6c 61 67 #f)) ;; #f flag
73d0: 73 20 64 6f 20 6e 6f 74 20 6c 6f 6f 70 0a 0a 20 s do not loop..
73e0: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 ((and (not (
73f0: 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 28 6d 65 null? fails))(me
7400: 6d 62 65 72 20 27 74 6f 70 6c 65 76 65 6c 20 74 mber 'toplevel t
7410: 65 73 74 6d 6f 64 65 29 29 0a 20 20 20 20 20 20 estmode)).
7420: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 (if (or (not (nu
7430: 6c 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e ll? reg))(not (n
7440: 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 ull? tal)))..
7450: 28 6c 69 73 74 20 28 63 61 72 20 6e 65 77 74 61 (list (car newta
7460: 6c 29 28 61 70 70 65 6e 64 20 28 63 64 72 20 6e l)(append (cdr n
7470: 65 77 74 61 6c 29 20 72 65 67 29 20 27 28 29 20 ewtal) reg) '()
7480: 72 65 72 75 6e 73 29 0a 09 20 20 23 66 29 29 20 reruns).. #f))
7490: 0a 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 75 . ((null? ru
74a0: 6e 6e 61 62 6c 65 73 29 20 23 66 29 20 3b 3b 20 nnables) #f) ;;
74b0: 69 66 20 77 65 20 67 65 74 20 68 65 72 65 20 61 if we get here a
74c0: 6e 64 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 nd non-completed
74d0: 20 69 73 20 6e 75 6c 6c 20 74 68 65 20 69 74 27 is null the it'
74e0: 73 20 61 6c 6c 20 6f 76 65 72 2e 0a 20 20 20 20 s all over..
74f0: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 64 65 (else. (de
7500: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
7510: 4e 49 4e 47 3a 20 46 41 49 4c 53 20 6f 72 20 69 NING: FAILS or i
7520: 6e 63 6f 6d 70 6c 65 74 65 20 74 65 73 74 73 20 ncomplete tests
7530: 6d 61 79 62 65 20 70 72 65 76 65 6e 74 69 6e 67 maybe preventing
7540: 20 63 6f 6d 70 6c 65 74 69 6f 6e 20 6f 66 20 74 completion of t
7550: 68 69 73 20 72 75 6e 2e 20 57 61 74 63 68 20 66 his run. Watch f
7560: 6f 72 20 69 73 73 75 65 73 20 77 69 74 68 20 74 or issues with t
7570: 65 73 74 20 22 20 68 65 64 20 22 2c 20 63 6f 6e est " hed ", con
7580: 74 69 6e 75 69 6e 67 20 66 6f 72 20 6e 6f 77 22 tinuing for now"
7590: 29 0a 20 20 20 20 20 20 3b 3b 20 28 6c 69 73 74 ). ;; (list
75a0: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
75b0: 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t-hed tal reg re
75c0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 20 20 glen regfull).
75d0: 20 20 20 20 3b 3b 20 20 20 09 28 72 75 6e 73 3a ;; .(runs:
75e0: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
75f0: 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 al reg reglen re
7600: 67 66 75 6c 6c 29 0a 20 20 20 20 20 20 3b 3b 20 gfull). ;;
7610: 20 20 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e .(runs:queue-n
7620: 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 ext-reg tal reg
7630: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
7640: 20 20 20 20 20 20 3b 3b 20 20 20 09 72 65 72 75 ;; .reru
7650: 6e 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 ns). (list
7660: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
7670: 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 newtal) reg rer
7680: 75 6e 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e uns)))))..(defin
7690: 65 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 e (runs:mixed-li
76a0: 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d st-testname-and-
76b0: 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 testrec->list-of
76c0: 2d 73 74 72 69 6e 67 73 20 69 6e 6c 73 74 29 0a -strings inlst).
76d0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 69 6e 6c (if (null? inl
76e0: 73 74 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 st). '().
76f0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
7700: 20 28 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 64 (t).. (cond
7710: 0a 09 20 20 20 20 20 20 28 28 76 65 63 74 6f 72 .. ((vector
7720: 3f 20 74 29 0a 09 20 20 20 20 20 20 20 28 6c 65 ? t).. (le
7730: 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 t ((test-name (d
7740: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
7750: 61 6d 65 20 74 29 29 0a 09 09 20 20 20 20 20 28 ame t))... (
7760: 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 item-path (db:te
7770: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
7780: 20 74 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 t))... (tes
7790: 74 2d 73 74 61 74 65 20 28 64 62 3a 74 65 73 74 t-state (db:test
77a0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 0a 09 -get-state t))..
77b0: 09 20 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 . (test-stat
77c0: 75 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d us (db:test-get-
77d0: 73 74 61 74 75 73 20 74 29 29 29 0a 09 09 20 28 status t)))... (
77e0: 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 28 conc test-name (
77f0: 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d if (equal? item-
7800: 70 61 74 68 20 22 22 29 20 22 22 20 22 2f 22 29 path "") "" "/")
7810: 20 69 74 65 6d 2d 70 61 74 68 20 22 3a 22 20 74 item-path ":" t
7820: 65 73 74 2d 73 74 61 74 65 20 22 2f 22 20 74 65 est-state "/" te
7830: 73 74 2d 73 74 61 74 75 73 29 29 29 0a 09 20 20 st-status)))..
7840: 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 74 29 ((string? t)
7850: 0a 09 20 20 20 20 20 20 20 74 29 0a 09 20 20 20 .. t)..
7860: 20 20 20 28 65 6c 73 65 20 0a 09 20 20 20 20 20 (else ..
7870: 20 20 28 63 6f 6e 63 20 74 29 29 29 29 0a 09 20 (conc t))))..
7880: 20 20 69 6e 6c 73 74 29 29 29 0a 0a 28 64 65 66 inlst)))..(def
7890: 69 6e 65 20 28 72 75 6e 73 3a 70 72 6f 63 65 73 ine (runs:proces
78a0: 73 2d 65 78 70 61 6e 64 65 64 2d 74 65 73 74 73 s-expanded-tests
78b0: 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 72 hed tal reg rer
78c0: 75 6e 73 20 72 65 67 6c 65 6e 20 72 65 67 66 75 uns reglen regfu
78d0: 6c 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 20 72 ll test-record r
78e0: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 unname test-name
78f0: 20 69 74 65 6d 2d 70 61 74 68 20 6a 6f 62 67 72 item-path jobgr
7900: 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 oup max-concurre
7910: 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 77 nt-jobs run-id w
7920: 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 aitons item-path
7930: 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d 70 testmode test-p
7940: 61 74 74 73 20 72 65 71 75 69 72 65 64 2d 74 65 atts required-te
7950: 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 sts test-registr
7960: 79 20 72 65 67 69 73 74 72 79 2d 6d 75 74 65 78 y registry-mutex
7970: 20 66 6c 61 67 73 20 6b 65 79 76 61 6c 73 20 72 flags keyvals r
7980: 75 6e 2d 69 6e 66 6f 20 6e 65 77 74 61 6c 20 61 un-info newtal a
7990: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
79a0: 79 20 69 74 65 6d 6d 61 70 20 61 72 65 61 2d 64 y itemmap area-d
79b0: 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f at). (let* ((co
79c0: 6e 66 69 67 64 61 74 20 20 20 20 20 20 20 20 20 nfigdat
79d0: 20 20 20 20 20 20 28 6d 65 67 61 74 65 73 74 3a (megatest:
79e0: 61 72 65 61 2d 63 6f 6e 66 69 67 64 61 74 20 61 area-configdat a
79f0: 72 65 61 2d 64 61 74 29 29 0a 09 20 28 74 6f 70 rea-dat)).. (top
7a00: 70 61 74 68 20 20 20 20 20 20 20 20 20 20 20 20 path
7a10: 20 20 20 20 20 28 6d 65 67 61 74 65 73 74 3a 61 (megatest:a
7a20: 72 65 61 2d 70 61 74 68 20 20 20 20 20 20 61 72 rea-path ar
7a30: 65 61 2d 64 61 74 29 29 0a 09 20 28 72 75 6e 2d ea-dat)).. (run-
7a40: 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 20 20 20 20 limits-info
7a50: 20 20 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 (runs:can-ru
7a60: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 72 75 6e n-more-tests run
7a70: 2d 69 64 20 6a 6f 62 67 72 6f 75 70 20 6d 61 78 -id jobgroup max
7a80: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
7a90: 20 61 72 65 61 2d 64 61 74 29 29 20 3b 3b 20 6c area-dat)) ;; l
7aa0: 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 ook at the test
7ab0: 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 jobgroup and tot
7ac0: 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 20 jobs running..
7ad0: 28 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 (have-resources
7ae0: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 72 75 (car ru
7af0: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 29 0a n-limits-info)).
7b00: 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 . (num-running
7b10: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
7b20: 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d -ref run-limits-
7b30: 69 6e 66 6f 20 31 29 29 0a 09 20 28 6e 75 6d 2d info 1)).. (num-
7b40: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
7b50: 6f 75 70 20 28 6c 69 73 74 2d 72 65 66 20 72 75 oup (list-ref ru
7b60: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 29 n-limits-info 2)
7b70: 29 20 0a 09 20 28 6d 61 78 2d 63 6f 6e 63 75 72 ) .. (max-concur
7b80: 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 20 28 6c rent-jobs (l
7b90: 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 ist-ref run-limi
7ba0: 74 73 2d 69 6e 66 6f 20 33 29 29 0a 09 20 28 6a ts-info 3)).. (j
7bb0: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 ob-group-limit
7bc0: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 (list-ref
7bd0: 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f run-limits-info
7be0: 20 34 29 29 0a 09 20 28 70 72 65 72 65 71 73 2d 4)).. (prereqs-
7bf0: 6e 6f 74 2d 6d 65 74 20 20 20 20 20 20 20 20 20 not-met
7c00: 28 72 6d 74 3a 67 65 74 2d 70 72 65 72 65 71 73 (rmt:get-prereqs
7c10: 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 -not-met run-id
7c20: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
7c30: 68 20 74 65 73 74 6d 6f 64 65 20 61 72 65 61 2d h testmode area-
7c40: 64 61 74 20 69 74 65 6d 6d 61 70 3a 20 69 74 65 dat itemmap: ite
7c50: 6d 6d 61 70 29 29 0a 09 20 3b 3b 20 28 70 72 65 mmap)).. ;; (pre
7c60: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 20 20 20 reqs-not-met
7c70: 20 20 20 20 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 (mt:lazy-ge
7c80: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
7c90: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
7ca0: 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a item-path mode:
7cb0: 20 74 65 73 74 6d 6f 64 65 20 69 74 65 6d 6d 61 testmode itemma
7cc0: 70 3a 20 69 74 65 6d 6d 61 70 29 29 0a 09 20 28 p: itemmap)).. (
7cd0: 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 fails
7ce0: 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 (runs:ca
7cf0: 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 lc-fails prereqs
7d00: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 28 6e 6f -not-met)).. (no
7d10: 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 20 20 n-completed
7d20: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
7d30: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
7d40: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
7d50: 0a 09 20 28 6c 6f 6f 70 2d 6c 69 73 74 20 20 20 .. (loop-list
7d60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
7d70: 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t hed tal reg re
7d80: 72 75 6e 73 29 29 0a 09 20 3b 3b 20 63 6f 6e 66 runs)).. ;; conf
7d90: 69 67 75 72 65 20 74 68 65 20 6c 6f 61 64 20 72 igure the load r
7da0: 75 6e 6e 65 72 0a 09 20 28 6e 75 6d 63 70 75 73 unner.. (numcpus
7db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7dc0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d (common:get-num
7dd0: 2d 63 70 75 73 29 29 0a 09 20 28 6d 61 78 6c 6f -cpus)).. (maxlo
7de0: 61 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ad
7df0: 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (string->numb
7e00: 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a er (or (configf:
7e10: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
7e20: 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6d 61 78 "jobtools" "max
7e30: 6c 6f 61 64 22 29 20 22 33 22 29 29 29 0a 09 20 load") "3")))..
7e40: 28 77 61 69 74 64 65 6c 61 79 20 20 20 20 20 20 (waitdelay
7e50: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
7e60: 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f ->number (or (co
7e70: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
7e80: 66 69 67 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 figdat "jobtools
7e90: 22 20 22 77 61 69 74 64 65 6c 61 79 22 29 20 22 " "waitdelay") "
7ea0: 36 30 22 29 29 29 29 0a 20 20 20 20 28 64 65 62 60")))). (deb
7eb0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
7ec0: 22 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 3a "have-resources:
7ed0: 20 22 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 " have-resource
7ee0: 73 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d s " prereqs-not-
7ef0: 6d 65 74 3a 20 28 22 20 0a 09 09 20 20 20 20 20 met: (" ...
7f00: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7f10: 65 72 73 65 20 0a 09 09 20 20 20 20 20 20 20 28 erse ... (
7f20: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a map (lambda (t).
7f30: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 76 65 ... (if (ve
7f40: 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 20 20 28 ctor? t)..... (
7f50: 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 conc (db:test-ge
7f60: 74 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 t-state t) "/" (
7f70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
7f80: 75 73 20 74 29 29 0a 09 09 09 09 20 20 28 63 6f us t))..... (co
7f90: 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a 20 74 20 nc " WARNING: t
7fa0: 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 3d is not a vector=
7fb0: 22 20 74 20 29 29 29 0a 09 09 09 20 20 20 20 70 " t ))).... p
7fc0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 rereqs-not-met)
7fd0: 22 2c 20 22 29 20 22 29 20 66 61 69 6c 73 3a 20 ", ") ") fails:
7fe0: 22 20 66 61 69 6c 73 29 0a 20 20 20 20 0a 20 20 " fails). .
7ff0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
8000: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n
8010: 6f 74 2d 6d 65 74 29 29 0a 09 20 20 20 20 20 28 ot-met)).. (
8020: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 runs:lownoise (c
8030: 6f 6e 63 20 22 77 61 69 74 69 6e 67 20 6f 6e 20 onc "waiting on
8040: 74 65 73 74 73 20 22 20 70 72 65 72 65 71 73 2d tests " prereqs-
8050: 6e 6f 74 2d 6d 65 74 20 68 65 64 29 20 36 30 29 not-met hed) 60)
8060: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d )..(debug:print-
8070: 69 6e 66 6f 20 32 20 22 77 61 69 74 69 6e 67 20 info 2 "waiting
8080: 6f 6e 20 74 65 73 74 73 3b 20 22 20 28 73 74 72 on tests; " (str
8090: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
80a0: 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c 69 73 74 (runs:mixed-list
80b0: 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 2d 74 65 -testname-and-te
80c0: 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f 66 2d 73 strec->list-of-s
80d0: 74 72 69 6e 67 73 20 70 72 65 72 65 71 73 2d 6e trings prereqs-n
80e0: 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 29 29 0a ot-met) ", "))).
80f0: 0a 20 20 20 20 3b 3b 20 44 6f 6e 27 74 20 6b 6e . ;; Don't kn
8100: 6f 77 20 61 74 20 74 68 69 73 20 74 69 6d 65 20 ow at this time
8110: 69 66 20 74 68 65 20 74 65 73 74 20 68 61 76 65 if the test have
8120: 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 64 20 61 been launched a
8130: 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 6e 20 74 t some time in t
8140: 68 65 20 70 61 73 74 0a 20 20 20 20 3b 3b 20 69 he past. ;; i
8150: 2e 65 2e 20 69 73 20 74 68 69 73 20 61 20 72 65 .e. is this a re
8160: 2d 6c 61 75 6e 63 68 3f 0a 20 20 20 20 28 64 65 -launch?. (de
8170: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
8180: 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 "run-limits-inf
8190: 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d 69 74 73 o = " run-limits
81a0: 2d 69 6e 66 6f 29 0a 20 20 20 20 0a 20 20 20 20 -info). .
81b0: 28 63 6f 6e 64 0a 20 20 20 20 20 0a 20 20 20 20 (cond. .
81c0: 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 6d 20 70 ;; Check item p
81d0: 61 74 68 20 61 67 61 69 6e 73 74 20 69 74 65 6d ath against item
81e0: 2d 70 61 74 74 73 2c 20 0a 20 20 20 20 20 3b 3b -patts, . ;;
81f0: 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 74 65 73 . ((not (tes
8200: 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 ts:match test-pa
8210: 74 74 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 tts (tests:testq
8220: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
8230: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 69 e test-record) i
8240: 74 65 6d 2d 70 61 74 68 20 72 65 71 75 69 72 65 tem-path require
8250: 64 3a 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 d: required-test
8260: 73 29 29 20 3b 3b 20 54 68 69 73 20 74 65 73 74 s)) ;; This test
8270: 2f 69 74 65 6d 70 61 74 68 20 69 73 20 6e 6f 74 /itempath is not
8280: 20 74 6f 20 62 65 20 72 75 6e 0a 20 20 20 20 20 to be run.
8290: 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 75 6e ;; else the run
82a0: 20 69 73 20 73 74 75 63 6b 2c 20 74 65 6d 70 6f is stuck, tempo
82b0: 72 61 72 69 6c 79 20 6f 72 20 70 65 72 6d 61 6e rarily or perman
82c0: 65 6e 74 6c 79 0a 20 20 20 20 20 20 3b 3b 20 62 ently. ;; b
82d0: 75 74 20 73 68 6f 75 6c 64 20 63 68 65 63 6b 20 ut should check
82e0: 69 66 20 69 74 20 69 73 20 64 75 65 20 74 6f 20 if it is due to
82f0: 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 63 65 lack of resource
8300: 73 20 76 73 2e 20 70 72 65 72 65 71 75 69 73 69 s vs. prerequisi
8310: 74 65 73 0a 20 20 20 20 20 20 28 64 65 62 75 67 tes. (debug
8320: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 53 :print-info 1 "S
8330: 6b 69 70 70 69 6e 67 20 22 20 28 74 65 73 74 73 kipping " (tests
8340: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
8350: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
8360: 6f 72 64 29 20 22 20 22 20 69 74 65 6d 2d 70 61 ord) " " item-pa
8370: 74 68 20 22 20 61 73 20 69 74 20 64 6f 65 73 6e th " as it doesn
8380: 27 74 20 6d 61 74 63 68 20 22 20 74 65 73 74 2d 't match " test-
8390: 70 61 74 74 73 29 0a 20 20 20 20 20 20 28 69 66 patts). (if
83a0: 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (or (not (null?
83b0: 20 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 6c 6c tal))(not (null
83c0: 3f 20 72 65 67 29 29 29 0a 09 20 20 28 6c 69 73 ? reg))).. (lis
83d0: 74 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 t (runs:queue-ne
83e0: 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 xt-hed tal reg r
83f0: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
8400: 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 .(runs:queue-nex
8410: 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 65 t-tal tal reg re
8420: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
8430: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
8440: 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 65 67 -reg tal reg reg
8450: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 72 len regfull)...r
8460: 65 72 75 6e 73 29 0a 09 20 20 23 66 29 29 0a 20 eruns).. #f)).
8470: 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 52 65 67 . ;; Reg
8480: 69 73 74 65 72 20 74 65 73 74 73 20 0a 20 20 20 ister tests .
8490: 20 20 3b 3b 0a 20 20 20 20 20 28 28 6e 6f 74 20 ;;. ((not
84a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
84b0: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 default test-reg
84c0: 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d istry (db:test-m
84d0: 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 ake-full-name te
84e0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
84f0: 68 29 20 23 66 29 29 0a 20 20 20 20 20 20 28 64 h) #f)). (d
8500: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8510: 34 20 22 50 72 65 2d 72 65 67 69 73 74 65 72 69 4 "Pre-registeri
8520: 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e ng test " test-n
8530: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
8540: 68 20 22 20 74 6f 20 63 72 65 61 74 65 20 70 6c h " to create pl
8550: 61 63 65 68 6f 6c 64 65 72 22 20 29 0a 20 20 20 aceholder" ).
8560: 20 20 20 3b 3b 20 61 6c 77 61 79 73 20 64 6f 20 ;; always do
8570: 66 69 72 6d 20 72 65 67 69 73 74 72 61 74 69 6f firm registratio
8580: 6e 20 6e 6f 77 20 69 6e 20 76 31 2e 36 30 20 61 n now in v1.60 a
8590: 6e 64 20 67 72 65 61 74 65 72 20 3b 3b 20 28 65 nd greater ;; (e
85a0: 71 3f 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 q? *transport-ty
85b0: 70 65 2a 20 27 66 73 29 20 3b 3b 20 6e 6f 20 70 pe* 'fs) ;; no p
85c0: 6f 69 6e 74 20 69 6e 20 70 61 72 61 6c 6c 65 6c oint in parallel
85d0: 20 72 65 67 69 73 74 72 61 74 69 6f 6e 20 69 66 registration if
85e0: 20 75 73 65 20 66 73 0a 20 20 20 20 20 20 28 6c use fs. (l
85f0: 65 74 20 72 65 67 69 73 74 65 72 2d 6c 6f 6f 70 et register-loop
8600: 20 28 28 6e 75 6d 74 72 69 65 73 20 31 35 29 29 ((numtries 15))
8610: 0a 09 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 ..(rmt:general-c
8620: 61 6c 6c 20 27 72 65 67 69 73 74 65 72 2d 74 65 all 'register-te
8630: 73 74 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 st run-id area-d
8640: 61 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e at run-id test-n
8650: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
8660: 28 69 66 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (if (rmt:get-tes
8670: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
8680: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
8690: 0a 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl
86a0: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 e-set! test-regi
86b0: 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 stry (db:test-ma
86c0: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
86d0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
86e0: 29 20 27 64 6f 6e 65 29 0a 09 20 20 20 20 28 69 ) 'done).. (i
86f0: 66 20 28 3e 20 6e 75 6d 74 72 69 65 73 20 30 29 f (> numtries 0)
8700: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 74 ...(begin... (t
8710: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 hread-sleep! 0.5
8720: 29 0a 09 09 20 20 28 72 65 67 69 73 74 65 72 2d )... (register-
8730: 6c 6f 6f 70 20 28 2d 20 6e 75 6d 74 72 69 65 73 loop (- numtries
8740: 20 31 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 1)))...(debug:p
8750: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 66 rint 0 "ERROR: f
8760: 61 69 6c 65 64 20 74 6f 20 72 65 67 69 73 74 65 ailed to registe
8770: 72 20 74 65 73 74 20 22 20 28 64 62 3a 74 65 73 r test " (db:tes
8780: 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 t-make-full-name
8790: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
87a0: 70 61 74 68 29 29 29 29 29 0a 20 20 20 20 20 20 path))))).
87b0: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 68 (if (not (eq? (h
87c0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
87d0: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 fault test-regis
87e0: 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b try (db:test-mak
87f0: 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 e-full-name test
8800: 2d 6e 61 6d 65 20 22 22 29 20 23 66 29 20 27 64 -name "") #f) 'd
8810: 6f 6e 65 29 29 0a 09 20 20 28 62 65 67 69 6e 0a one)).. (begin.
8820: 09 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 . (rmt:genera
8830: 6c 2d 63 61 6c 6c 20 27 72 65 67 69 73 74 65 72 l-call 'register
8840: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 61 72 65 -test run-id are
8850: 61 2d 64 61 74 20 72 75 6e 2d 69 64 20 74 65 73 a-dat run-id tes
8860: 74 2d 6e 61 6d 65 20 22 22 29 0a 09 20 20 20 20 t-name "")..
8870: 28 69 66 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (if (rmt:get-tes
8880: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
8890: 2d 6e 61 6d 65 20 22 22 29 0a 09 09 28 68 61 73 -name "")...(has
88a0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
88b0: 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 3a 74 t-registry (db:t
88c0: 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 est-make-full-na
88d0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 me test-name "")
88e0: 20 27 64 6f 6e 65 29 29 29 29 0a 20 20 20 20 20 'done)))).
88f0: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
8900: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
8910: 2d 63 6f 75 6e 74 29 20 20 20 3b 3b 20 44 45 4c -count) ;; DEL
8920: 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c AY TWEAKER (stil
8930: 6c 20 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 20 l needed?).
8940: 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f (if (and (null?
8950: 20 74 61 6c 29 28 6e 75 6c 6c 3f 20 72 65 67 29 tal)(null? reg)
8960: 29 0a 09 20 20 28 6c 69 73 74 20 68 65 64 20 74 ).. (list hed t
8970: 61 6c 20 28 61 70 70 65 6e 64 20 72 65 67 20 28 al (append reg (
8980: 6c 69 73 74 20 68 65 64 29 29 20 72 65 72 75 6e list hed)) rerun
8990: 73 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 6e s).. (list (run
89a0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 s:queue-next-hed
89b0: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
89c0: 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 regfull)...(runs
89d0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal
89e0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
89f0: 65 67 66 75 6c 6c 29 0a 09 09 3b 3b 20 4e 42 2f egfull)...;; NB/
8a00: 2f 20 48 65 72 65 20 77 65 20 61 72 65 20 62 75 / Here we are bu
8a10: 69 6c 64 69 6e 67 20 72 65 67 20 61 73 20 77 65 ilding reg as we
8a20: 20 72 65 67 69 73 74 65 72 20 74 65 73 74 73 0a register tests.
8a30: 09 09 3b 3b 20 69 66 20 72 65 67 66 75 6c 6c 20 ..;; if regfull
8a40: 77 65 20 6d 75 73 74 20 70 6f 70 20 74 68 65 20 we must pop the
8a50: 66 72 6f 6e 74 20 69 74 65 6d 20 6f 66 66 20 72 front item off r
8a60: 65 67 0a 09 09 28 69 66 20 72 65 67 66 75 6c 6c eg...(if regfull
8a70: 0a 09 09 20 20 20 20 28 61 70 70 65 6e 64 20 28 ... (append (
8a80: 63 64 72 20 72 65 67 29 20 28 6c 69 73 74 20 68 cdr reg) (list h
8a90: 65 64 29 29 0a 09 09 20 20 20 20 28 61 70 70 65 ed))... (appe
8aa0: 6e 64 20 72 65 67 20 28 6c 69 73 74 20 68 65 64 nd reg (list hed
8ab0: 29 29 29 0a 09 09 72 65 72 75 6e 73 29 29 29 0a )))...reruns))).
8ac0: 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 41 74 . ;; At
8ad0: 20 74 68 69 73 20 70 6f 69 6e 74 20 68 65 64 20 this point hed
8ae0: 74 65 73 74 20 72 65 67 69 73 74 72 61 74 69 6f test registratio
8af0: 6e 20 6d 75 73 74 20 62 65 20 63 6f 6d 70 6c 65 n must be comple
8b00: 74 65 64 2e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 ted.. ;;.
8b10: 20 20 28 28 65 71 3f 20 28 68 61 73 68 2d 74 61 ((eq? (hash-ta
8b20: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8b30: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 test-registry (d
8b40: 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c b:test-make-full
8b50: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
8b60: 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 0a 09 item-path) #f)..
8b70: 20 20 20 27 73 74 61 72 74 29 0a 20 20 20 20 20 'start).
8b80: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8b90: 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 6f 6e fo 0 "Waiting on
8ba0: 20 74 65 73 74 20 72 65 67 69 73 74 72 61 74 69 test registrati
8bb0: 6f 6e 28 73 29 3a 20 22 0a 09 09 09 28 73 74 72 on(s): "....(str
8bc0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
8bd0: 0a 09 09 09 20 28 66 69 6c 74 65 72 20 28 6c 61 .... (filter (la
8be0: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 20 20 mbda (x).....
8bf0: 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 (eq? (hash-table
8c00: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
8c10: 74 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 29 t-registry x #f)
8c20: 20 27 73 74 61 72 74 29 29 0a 09 09 09 09 20 28 'start))..... (
8c30: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
8c40: 74 65 73 74 2d 72 65 67 69 73 74 72 79 29 29 0a test-registry)).
8c50: 09 09 09 20 22 2c 20 22 29 29 0a 20 20 20 20 20 ... ", ")).
8c60: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
8c70: 30 2e 30 35 31 29 0a 20 20 20 20 20 20 28 6c 69 0.051). (li
8c80: 73 74 20 68 65 64 20 74 61 6c 20 72 65 67 20 72 st hed tal reg r
8c90: 65 72 75 6e 73 29 29 0a 20 20 20 20 20 0a 20 20 eruns)). .
8ca0: 20 20 20 3b 3b 20 49 66 20 6e 6f 20 72 65 73 6f ;; If no reso
8cb0: 75 72 63 65 73 20 61 72 65 20 61 76 61 69 6c 61 urces are availa
8cc0: 62 6c 65 20 6a 75 73 74 20 6b 69 6c 6c 20 74 69 ble just kill ti
8cd0: 6d 65 20 61 6e 64 20 6c 6f 6f 70 20 61 67 61 69 me and loop agai
8ce0: 6e 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 28 n. ;;. (
8cf0: 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 (not have-resour
8d00: 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 ces) ;; simply t
8d10: 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 ry again after w
8d20: 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a aiting a second.
8d30: 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a (if (runs:
8d40: 6c 6f 77 6e 6f 69 73 65 20 22 6e 6f 20 72 65 73 lownoise "no res
8d50: 6f 75 72 63 65 73 22 20 36 30 29 0a 09 20 20 28 ources" 60).. (
8d60: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
8d70: 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 73 1 "no resources
8d80: 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 to run new test
8d90: 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 s, waiting ...")
8da0: 29 0a 20 20 20 20 20 20 3b 3b 20 48 61 76 65 20 ). ;; Have
8db0: 67 6f 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 6f gone back and fo
8dc0: 72 74 68 20 6f 6e 20 74 68 69 73 20 62 75 74 20 rth on this but
8dd0: 64 62 20 73 74 61 72 76 61 74 69 6f 6e 20 69 73 db starvation is
8de0: 20 61 6e 20 69 73 73 75 65 2e 0a 20 20 20 20 20 an issue..
8df0: 20 3b 3b 20 77 61 69 74 20 6f 6e 65 20 73 65 63 ;; wait one sec
8e00: 6f 6e 64 20 62 65 66 6f 72 65 20 6c 6f 6f 6b 69 ond before looki
8e10: 6e 67 20 61 67 61 69 6e 20 74 6f 20 72 75 6e 20 ng again to run
8e20: 6a 6f 62 73 2e 0a 20 20 20 20 20 20 28 74 68 72 jobs.. (thr
8e30: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 20 20 ead-sleep! 1).
8e40: 20 20 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 ;; could hav
8e50: 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 e done hed tal h
8e60: 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 61 ere but doing ca
8e70: 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 r/cdr of newtal
8e80: 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 0a to rotate tests.
8e90: 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 (list (car
8ea0: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
8eb0: 74 61 6c 29 20 72 65 67 20 72 65 72 75 6e 73 29 tal) reg reruns)
8ec0: 29 0a 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 20 ). . ;;
8ed0: 54 68 69 73 20 69 73 20 74 68 65 20 66 69 6e 61 This is the fina
8ee0: 6c 20 73 74 61 67 65 2c 20 65 76 65 72 79 74 68 l stage, everyth
8ef0: 69 6e 67 20 69 73 20 69 6e 20 70 6c 61 63 65 20 ing is in place
8f00: 73 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 so launch the te
8f10: 73 74 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 st. ;;.
8f20: 28 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 ((and have-resou
8f30: 72 63 65 73 0a 09 20 20 20 28 6f 72 20 28 6e 75 rces.. (or (nu
8f40: 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ll? prereqs-not-
8f50: 6d 65 74 29 0a 09 20 20 20 20 20 20 20 28 61 6e met).. (an
8f60: 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 d (eq? testmode
8f70: 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 20 20 20 'toplevel)...
8f80: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
8f90: 6c 65 74 65 64 29 29 29 29 0a 20 20 20 20 20 20 leted)))).
8fa0: 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 ;; (hash-table-d
8fb0: 65 6c 65 74 65 21 20 2a 6d 61 78 2d 74 72 69 65 elete! *max-trie
8fc0: 73 2d 68 61 73 68 2a 20 28 64 62 3a 74 65 73 74 s-hash* (db:test
8fd0: 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
8fe0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
8ff0: 61 74 68 29 29 0a 20 20 20 20 20 20 3b 3b 20 77 ath)). ;; w
9000: 65 20 61 72 65 20 67 6f 69 6e 67 20 74 6f 20 72 e are going to r
9010: 65 73 65 74 20 61 6c 6c 20 74 68 65 20 63 6f 75 eset all the cou
9020: 6e 74 65 72 73 20 66 6f 72 20 74 65 73 74 20 72 nters for test r
9030: 65 74 72 69 65 73 20 62 79 20 73 65 74 74 69 6e etries by settin
9040: 67 20 61 20 6e 65 77 20 68 61 73 68 20 74 61 62 g a new hash tab
9050: 6c 65 0a 20 20 20 20 20 20 3b 3b 20 74 68 69 73 le. ;; this
9060: 20 6d 65 61 6e 73 20 74 68 65 79 20 77 69 6c 6c means they will
9070: 20 69 6e 63 72 65 6d 65 6e 74 20 6f 6e 6c 79 20 increment only
9080: 77 68 65 6e 20 6e 6f 74 68 69 6e 67 20 63 61 6e when nothing can
9090: 20 62 65 20 72 75 6e 0a 20 20 20 20 20 20 28 73 be run. (s
90a0: 65 74 21 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 et! *max-tries-h
90b0: 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d ash* (make-hash-
90c0: 74 61 62 6c 65 29 29 0a 20 20 20 20 20 20 3b 3b table)). ;;
90d0: 20 77 65 6c 6c 2c 20 66 69 72 73 74 20 6c 65 74 well, first let
90e0: 73 20 73 65 65 20 69 66 20 63 70 75 20 6c 6f 61 s see if cpu loa
90f0: 64 20 74 68 72 6f 74 74 6c 69 6e 67 20 69 73 20 d throttling is
9100: 65 6e 61 62 6c 65 64 2e 20 49 66 20 73 6f 20 77 enabled. If so w
9110: 61 69 74 20 61 72 6f 75 6e 64 20 75 6e 74 69 6c ait around until
9120: 20 74 68 65 0a 20 20 20 20 20 20 3b 3b 20 61 76 the. ;; av
9130: 65 72 61 67 65 20 63 70 75 20 6c 6f 61 64 20 69 erage cpu load i
9140: 73 20 75 6e 64 65 72 20 74 68 65 20 74 68 72 65 s under the thre
9150: 73 68 6f 6c 64 20 62 65 66 6f 72 65 20 63 6f 6e shold before con
9160: 74 69 6e 75 69 6e 67 0a 20 20 20 20 20 20 28 69 tinuing. (i
9170: 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 f (configf:looku
9180: 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
9190: 74 6f 6f 6c 73 22 20 22 6d 61 78 6c 6f 61 64 22 tools" "maxload"
91a0: 29 20 3b 3b 20 6f 6e 6c 79 20 67 61 74 65 20 69 ) ;; only gate i
91b0: 66 20 6d 61 78 6c 6f 61 64 20 69 73 20 73 70 65 f maxload is spe
91c0: 63 69 66 69 65 64 0a 09 20 20 28 63 6f 6d 6d 6f cified.. (commo
91d0: 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f n:wait-for-cpulo
91e0: 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 ad maxload numcp
91f0: 75 73 20 77 61 69 74 64 65 6c 61 79 29 29 0a 20 us waitdelay)).
9200: 20 20 20 20 20 28 72 75 6e 3a 74 65 73 74 20 72 (run:test r
9210: 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b un-id run-info k
9220: 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 eyvals runname t
9230: 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 est-record flags
9240: 20 23 66 20 74 65 73 74 2d 72 65 67 69 73 74 72 #f test-registr
9250: 79 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 y all-tests-regi
9260: 73 74 72 79 20 61 72 65 61 2d 64 61 74 29 0a 20 stry area-dat).
9270: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
9280: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
9290: 74 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b try (db:test-mak
92a0: 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 e-full-name test
92b0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
92c0: 20 27 72 75 6e 6e 69 6e 67 29 0a 20 20 20 20 20 'running).
92d0: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
92e0: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
92f0: 2d 63 6f 75 6e 74 29 20 20 3b 3b 20 44 45 4c 41 -count) ;; DELA
9300: 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c Y TWEAKER (still
9310: 20 6e 65 65 64 65 64 3f 29 0a 20 20 20 20 20 20 needed?).
9320: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
9330: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
9340: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 ). (if (or
9350: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
9360: 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 )(not (null? reg
9370: 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 72 75 ))).. (list (ru
9380: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
9390: 64 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e d tal reg reglen
93a0: 20 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e regfull)...(run
93b0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c s:queue-next-tal
93c0: 20 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 tal reg reglen
93d0: 72 65 67 66 75 6c 6c 29 0a 09 09 28 72 75 6e 73 regfull)...(runs
93e0: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
93f0: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
9400: 65 67 66 75 6c 6c 29 0a 09 09 72 65 72 75 6e 73 egfull)...reruns
9410: 29 0a 09 20 20 23 66 29 29 0a 20 20 20 20 20 0a ).. #f)). .
9420: 20 20 20 20 20 3b 3b 20 6d 75 73 74 20 62 65 20 ;; must be
9430: 77 65 20 68 61 76 65 20 75 6e 6d 65 74 20 70 72 we have unmet pr
9440: 65 72 65 71 75 69 73 69 74 65 73 0a 20 20 20 20 erequisites.
9450: 20 3b 3b 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 ;;. (else.
9460: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9470: 74 20 34 20 22 46 41 49 4c 53 3a 20 22 20 66 61 t 4 "FAILS: " fa
9480: 69 6c 73 29 0a 20 20 20 20 20 20 3b 3b 20 49 66 ils). ;; If
9490: 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 20 6f 66 20 one or more of
94a0: 74 68 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d the prereqs-not-
94b0: 6d 65 74 20 61 72 65 20 46 41 49 4c 20 74 68 65 met are FAIL the
94c0: 6e 20 77 65 20 63 61 6e 20 69 73 73 75 65 0a 20 n we can issue.
94d0: 20 20 20 20 20 3b 3b 20 61 20 6d 65 73 73 61 67 ;; a messag
94e0: 65 20 61 6e 64 20 64 72 6f 70 20 68 65 64 20 66 e and drop hed f
94f0: 72 6f 6d 20 74 68 65 20 69 74 65 6d 73 20 74 6f rom the items to
9500: 20 62 65 20 70 72 6f 63 65 73 73 65 64 2e 0a 20 be processed..
9510: 20 20 20 20 20 3b 3b 20 28 72 75 6e 73 3a 6d 69 ;; (runs:mi
9520: 78 65 64 2d 6c 69 73 74 2d 74 65 73 74 6e 61 6d xed-list-testnam
9530: 65 2d 61 6e 64 2d 74 65 73 74 72 65 63 2d 3e 6c e-and-testrec->l
9540: 69 73 74 2d 6f 66 2d 73 74 72 69 6e 67 73 20 70 ist-of-strings p
9550: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
9560: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
9570: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 not (null? prere
9580: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 20 20 qs-not-met))..
9590: 20 20 20 20 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f (runs:lowno
95a0: 69 73 65 20 28 63 6f 6e 63 20 22 77 61 69 74 69 ise (conc "waiti
95b0: 6e 67 20 6f 6e 20 74 65 73 74 73 20 22 20 70 72 ng on tests " pr
95c0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 68 65 ereqs-not-met he
95d0: 64 29 20 36 30 29 29 0a 09 20 20 28 64 65 62 75 d) 60)).. (debu
95e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
95f0: 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 73 waiting on tests
9600: 3b 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 ; " (string-inte
9610: 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 20 rsperse .......
9620: 20 20 20 28 72 75 6e 73 3a 6d 69 78 65 64 2d 6c (runs:mixed-l
9630: 69 73 74 2d 74 65 73 74 6e 61 6d 65 2d 61 6e 64 ist-testname-and
9640: 2d 74 65 73 74 72 65 63 2d 3e 6c 69 73 74 2d 6f -testrec->list-o
9650: 66 2d 73 74 72 69 6e 67 73 20 0a 09 09 09 09 09 f-strings ......
9660: 09 20 20 20 20 20 70 72 65 72 65 71 73 2d 6e 6f . prereqs-no
9670: 74 2d 6d 65 74 29 20 22 2c 20 22 29 29 29 0a 20 t-met) ", "))).
9680: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
9690: 66 61 69 6c 73 29 0a 09 20 20 28 62 65 67 69 6e fails).. (begin
96a0: 0a 09 20 20 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 .. ;; couldn'
96b0: 74 20 72 75 6e 2c 20 74 61 6b 65 20 61 20 62 72 t run, take a br
96c0: 65 61 74 68 65 72 0a 09 20 20 20 20 28 69 66 20 eather.. (if
96d0: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
96e0: 22 57 61 69 74 69 6e 67 20 66 6f 72 20 6d 6f 72 "Waiting for mor
96f0: 65 20 77 6f 72 6b 20 74 6f 20 64 6f 2e 2e 2e 22 e work to do..."
9700: 20 36 30 29 0a 09 09 20 28 64 65 62 75 67 3a 70 60)... (debug:p
9710: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 rint-info 0 "Wai
9720: 74 69 6e 67 20 66 6f 72 20 6d 6f 72 65 20 77 6f ting for more wo
9730: 72 6b 20 74 6f 20 64 6f 2e 2e 2e 22 29 29 0a 09 rk to do..."))..
9740: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
9750: 70 21 20 31 29 0a 09 20 20 20 20 28 6c 69 73 74 p! 1).. (list
9760: 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 (car newtal)(cd
9770: 72 20 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 r newtal) reg re
9780: 72 75 6e 73 29 29 0a 09 20 20 3b 3b 20 74 68 65 runs)).. ;; the
9790: 20 77 61 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 waiton is FAIL
97a0: 73 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 so no point in t
97b0: 72 79 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 rying to run hed
97c0: 20 65 76 65 72 20 61 67 61 69 6e 0a 09 20 20 28 ever again.. (
97d0: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
97e0: 6c 3f 20 72 65 67 29 29 28 6e 6f 74 20 28 6e 75 l? reg))(not (nu
97f0: 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 20 20 20 20 ll? tal)))..
9800: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 (if (vector? h
9810: 65 64 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 ed)... (begin..
9820: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
9830: 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 44 72 t 1 "WARNING: Dr
9840: 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 74 65 opping test " te
9850: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
9860: 2d 70 61 74 68 0a 09 09 09 09 20 22 20 66 72 6f -path..... " fro
9870: 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 m the launch lis
9880: 74 20 61 73 20 69 74 20 68 61 73 20 70 72 65 72 t as it has prer
9890: 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 72 equistes that ar
98a0: 65 20 46 41 49 4c 22 29 0a 09 09 20 20 20 20 28 e FAIL")... (
98b0: 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 let ((test-id (r
98c0: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
98d0: 75 6e 2d 69 64 20 68 65 64 20 22 22 29 29 29 0a un-id hed ""))).
98e0: 09 09 20 20 20 20 20 20 28 69 66 20 74 65 73 74 .. (if test
98f0: 2d 69 64 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 -id (mt:test-set
9900: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
9910: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
9920: 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 id "NOT_STARTED"
9930: 20 22 50 52 45 51 5f 46 41 49 4c 22 20 22 46 61 "PREQ_FAIL" "Fa
9940: 69 6c 65 64 20 74 6f 20 72 75 6e 20 64 75 65 20 iled to run due
9950: 74 6f 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 to failed prereq
9960: 75 69 73 69 74 65 73 22 29 29 29 0a 09 09 20 20 uisites")))...
9970: 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 (runs:shrink-c
9980: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
9990: 73 2d 63 6f 75 6e 74 29 20 3b 3b 20 44 45 4c 41 s-count) ;; DELA
99a0: 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c Y TWEAKER (still
99b0: 20 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 20 20 needed?)...
99c0: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
99d0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
99e0: 29 0a 09 09 20 20 20 20 3b 3b 20 54 68 69 73 20 )... ;; This
99f0: 6e 65 78 74 20 69 73 20 66 6f 72 20 74 68 65 20 next is for the
9a00: 69 74 65 6d 73 0a 09 09 20 20 20 20 28 6d 74 3a items... (mt:
9a10: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
9a20: 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d tatus-by-testnam
9a30: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 e run-id test-na
9a40: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 22 4e 4f me item-path "NO
9a50: 54 5f 53 54 41 52 54 45 44 22 20 22 42 4c 4f 43 T_STARTED" "BLOC
9a60: 4b 45 44 22 20 23 66 29 0a 09 09 20 20 20 20 28 KED" #f)... (
9a70: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9a80: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 test-registry (d
9a90: 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c b:test-make-full
9aa0: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
9ab0: 69 74 65 6d 2d 70 61 74 68 29 20 27 72 65 6d 6f item-path) 'remo
9ac0: 76 65 64 29 0a 09 09 20 20 20 20 28 6c 69 73 74 ved)... (list
9ad0: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
9ae0: 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 65 t-hed tal reg re
9af0: 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 glen regfull)...
9b00: 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e . (runs:queue-n
9b10: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
9b20: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
9b30: 09 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 65 ... (runs:queue
9b40: 2d 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 -next-reg tal re
9b50: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
9b60: 29 0a 09 09 09 20 20 72 65 72 75 6e 73 20 3b 3b ).... reruns ;;
9b70: 20 57 41 53 3a 20 28 63 6f 6e 73 20 68 65 64 20 WAS: (cons hed
9b80: 72 65 72 75 6e 73 29 20 3b 3b 20 62 75 74 20 74 reruns) ;; but t
9b90: 68 61 74 20 6d 61 6b 65 73 20 6e 6f 20 73 65 6e hat makes no sen
9ba0: 73 65 3f 0a 09 09 09 20 20 29 29 0a 09 09 20 20 se?.... ))...
9bb0: 28 6c 65 74 20 28 28 6e 74 68 2d 74 72 79 20 28 (let ((nth-try (
9bc0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
9bd0: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 efault test-regi
9be0: 73 74 72 79 20 68 65 64 20 30 29 29 29 0a 09 09 stry hed 0)))...
9bf0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
9c00: 20 28 28 6d 65 6d 62 65 72 20 22 52 55 4e 4e 49 ((member "RUNNI
9c10: 4e 47 22 20 28 6d 61 70 20 64 62 3a 74 65 73 74 NG" (map db:test
9c20: 2d 67 65 74 2d 73 74 61 74 65 20 70 72 65 72 65 -get-state prere
9c30: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 20 qs-not-met))...
9c40: 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c (if (runs:l
9c50: 6f 77 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 70 ownoise (conc "p
9c60: 6f 73 73 69 62 6c 65 20 52 55 4e 4e 49 4e 47 20 ossible RUNNING
9c70: 70 72 65 72 65 71 75 69 73 74 65 73 20 22 20 68 prerequistes " h
9c80: 65 64 29 20 36 30 29 0a 09 09 09 20 20 28 64 65 ed) 60).... (de
9c90: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
9ca0: 4e 49 4e 47 3a 20 74 65 73 74 20 22 20 68 65 64 NING: test " hed
9cb0: 20 22 20 68 61 73 20 70 6f 73 73 69 62 6c 65 20 " has possible
9cc0: 52 55 4e 4e 49 4e 47 20 70 72 65 72 65 71 75 69 RUNNING prerequi
9cd0: 73 69 74 65 73 2c 20 64 6f 6e 27 74 20 67 69 76 sites, don't giv
9ce0: 65 20 75 70 20 6f 6e 20 69 74 20 79 65 74 2e 22 e up on it yet."
9cf0: 29 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 ))... (thre
9d00: 61 64 2d 73 6c 65 65 70 21 20 34 29 0a 09 09 20 ad-sleep! 4)...
9d10: 20 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 (list (runs
9d20: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 :queue-next-hed
9d30: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
9d40: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
9d50: 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 (runs:queue-ne
9d60: 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 xt-tal newtal re
9d70: 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c g reglen regfull
9d80: 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 3a 71 ).... (runs:q
9d90: 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 ueue-next-reg ne
9da0: 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 wtal reg reglen
9db0: 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 regfull)....
9dc0: 72 65 72 75 6e 73 29 29 0a 09 09 20 20 20 20 20 reruns))...
9dd0: 28 28 6f 72 20 28 6e 6f 74 20 6e 74 68 2d 74 72 ((or (not nth-tr
9de0: 79 29 0a 09 09 09 20 20 28 61 6e 64 20 28 6e 75 y).... (and (nu
9df0: 6d 62 65 72 3f 20 6e 74 68 2d 74 72 79 29 0a 09 mber? nth-try)..
9e00: 09 09 20 20 20 20 20 20 20 28 3c 20 6e 74 68 2d .. (< nth-
9e10: 74 72 79 20 31 30 29 29 29 0a 09 09 20 20 20 20 try 10)))...
9e20: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
9e30: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
9e40: 20 68 65 64 20 28 69 66 20 28 6e 75 6d 62 65 72 hed (if (number
9e50: 3f 20 6e 74 68 2d 74 72 79 29 0a 09 09 09 09 09 ? nth-try)......
9e60: 09 09 20 20 20 20 20 28 2b 20 6e 74 68 2d 74 72 .. (+ nth-tr
9e70: 79 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 20 y 1)........
9e80: 20 30 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 0))... (if
9e90: 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 (runs:lownoise
9ea0: 28 63 6f 6e 63 20 22 6e 6f 74 20 72 65 6d 6f 76 (conc "not remov
9eb0: 69 6e 67 20 74 65 73 74 20 22 20 68 65 64 29 20 ing test " hed)
9ec0: 36 30 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 60).... (debug:
9ed0: 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 print 1 "WARNING
9ee0: 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 74 : not removing t
9ef0: 65 73 74 20 22 20 68 65 64 20 22 20 66 72 6f 6d est " hed " from
9f00: 20 71 75 65 75 65 20 61 6c 74 68 6f 75 67 68 20 queue although
9f10: 69 74 20 6d 61 79 20 6e 6f 74 20 62 65 20 72 75 it may not be ru
9f20: 6e 6e 61 62 6c 65 20 64 75 65 20 74 6f 20 46 41 nnable due to FA
9f30: 49 4c 45 44 20 70 72 65 72 65 71 75 69 73 69 74 ILED prerequisit
9f40: 65 73 22 29 29 0a 09 09 20 20 20 20 20 20 3b 3b es"))... ;;
9f50: 20 6d 61 79 20 6e 6f 74 20 68 61 76 65 20 70 72 may not have pr
9f60: 6f 63 65 73 73 65 64 20 63 6f 72 72 65 63 74 6c ocessed correctl
9f70: 79 2e 20 43 6f 75 6c 64 20 62 65 20 61 20 72 61 y. Could be a ra
9f80: 63 65 20 63 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 ce condition in
9f90: 79 6f 75 72 20 74 65 73 74 20 69 6d 70 6c 65 6d your test implem
9fa0: 65 6e 74 61 74 69 6f 6e 3f 20 44 72 6f 70 70 69 entation? Droppi
9fb0: 6e 67 20 74 65 73 74 20 22 20 68 65 64 29 20 3b ng test " hed) ;
9fc0: 3b 20 20 22 20 61 73 20 69 74 20 68 61 73 20 70 ; " as it has p
9fd0: 72 65 72 65 71 75 69 73 74 65 73 20 74 68 61 74 rerequistes that
9fe0: 20 61 72 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 are FAIL. (NOTE
9ff0: 3a 20 68 65 64 20 69 73 20 6e 6f 74 20 61 20 76 : hed is not a v
a000: 65 63 74 6f 72 29 22 29 0a 09 09 20 20 20 20 20 ector)")...
a010: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
a020: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
a030: 2d 63 6f 75 6e 74 29 20 3b 3b 20 44 45 4c 41 59 -count) ;; DELAY
a040: 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 TWEAKER (still
a050: 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 20 20 20 needed?)...
a060: 20 3b 3b 20 28 6c 69 73 74 20 68 65 64 20 74 61 ;; (list hed ta
a070: 6c 20 72 65 67 20 72 65 72 75 6e 73 29 0a 09 09 l reg reruns)...
a080: 20 20 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 28 ;; (list (
a090: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
a0a0: 6e 65 77 74 61 6c 29 20 72 65 67 20 72 65 72 75 newtal) reg reru
a0b0: 6e 73 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 ns)... ;; (
a0c0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
a0d0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 65 test-registry he
a0e0: 64 20 27 72 65 6d 6f 76 65 64 29 0a 09 09 20 20 d 'removed)...
a0f0: 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a (list (runs:
a100: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e queue-next-hed n
a110: 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e ewtal reg reglen
a120: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 regfull)....
a130: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex
a140: 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 t-tal newtal reg
a150: 20 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 reglen regfull)
a160: 0a 09 09 09 20 20 20 20 28 72 75 6e 73 3a 71 75 .... (runs:qu
a170: 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 eue-next-reg new
a180: 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 tal reg reglen r
a190: 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 20 20 72 egfull).... r
a1a0: 65 72 75 6e 73 29 29 0a 09 09 20 20 20 20 20 28 eruns))... (
a1b0: 28 73 79 6d 62 6f 6c 3f 20 6e 74 68 2d 74 72 79 (symbol? nth-try
a1c0: 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 )... (if (e
a1d0: 71 3f 20 6e 74 68 2d 74 72 79 20 27 72 65 6d 6f q? nth-try 'remo
a1e0: 76 65 64 29 20 3b 3b 20 72 65 6d 6f 76 65 64 20 ved) ;; removed
a1f0: 69 73 20 72 65 6d 6f 76 65 64 20 2d 20 64 72 6f is removed - dro
a200: 70 20 69 74 20 4e 4f 57 0a 09 09 09 20 20 28 69 p it NOW.... (i
a210: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
a220: 09 20 20 20 20 20 20 23 66 20 3b 3b 20 79 65 73 . #f ;; yes
a230: 2c 20 72 65 61 6c 6c 79 0a 09 09 09 20 20 20 20 , really....
a240: 20 20 28 6c 69 73 74 20 28 63 61 72 20 74 61 6c (list (car tal
a250: 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 20 72 )(cdr tal) reg r
a260: 65 72 75 6e 73 29 29 0a 09 09 09 20 20 28 62 65 eruns)).... (be
a270: 67 69 6e 0a 09 09 09 20 20 20 20 28 69 66 20 28 gin.... (if (
a280: 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 63 runs:lownoise (c
a290: 6f 6e 63 20 22 46 41 49 4c 45 44 20 70 72 65 72 onc "FAILED prer
a2a0: 65 71 75 69 73 69 74 65 73 20 6f 72 20 6f 74 68 equisites or oth
a2b0: 65 72 20 69 73 73 75 65 22 20 68 65 64 29 20 36 er issue" hed) 6
a2c0: 30 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 0).....(debug:pr
a2d0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
a2e0: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
a2f0: 20 46 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 FAILED prerequi
a300: 73 69 74 65 73 20 6f 72 20 6f 74 68 65 72 20 69 sites or other i
a310: 73 73 75 65 2e 20 49 6e 74 65 72 6e 61 6c 20 73 ssue. Internal s
a320: 74 61 74 65 20 22 20 6e 74 68 2d 74 72 79 20 22 tate " nth-try "
a330: 20 77 69 6c 6c 20 62 65 20 6f 76 65 72 72 69 64 will be overrid
a340: 64 65 6e 20 61 6e 64 20 77 65 27 6c 6c 20 72 65 den and we'll re
a350: 74 72 79 2e 22 29 29 0a 09 09 09 20 20 20 20 28 try.")).... (
a360: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
a370: 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 e-status-by-test
a380: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
a390: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
a3a0: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 4b "NOT_STARTED" "K
a3b0: 45 45 50 5f 54 52 59 49 4e 47 22 20 23 66 29 0a EEP_TRYING" #f).
a3c0: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
a3d0: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
a3e0: 69 73 74 72 79 20 68 65 64 20 30 29 0a 09 09 09 istry hed 0)....
a3f0: 20 20 20 20 28 6c 69 73 74 20 28 72 75 6e 73 3a (list (runs:
a400: 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 64 20 6e queue-next-hed n
a410: 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 6e ewtal reg reglen
a420: 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 09 20 20 regfull).....
a430: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
a440: 2d 74 61 6c 20 6e 65 77 74 61 6c 20 72 65 67 20 -tal newtal reg
a450: 72 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a reglen regfull).
a460: 09 09 09 09 20 20 28 72 75 6e 73 3a 71 75 65 75 .... (runs:queu
a470: 65 2d 6e 65 78 74 2d 72 65 67 20 6e 65 77 74 61 e-next-reg newta
a480: 6c 20 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 l reg reglen reg
a490: 66 75 6c 6c 29 0a 09 09 09 09 20 20 72 65 72 75 full)..... reru
a4a0: 6e 73 29 29 29 29 0a 09 09 20 20 20 20 20 28 65 ns))))... (e
a4b0: 6c 73 65 0a 09 09 20 20 20 20 20 20 28 69 66 20 lse... (if
a4c0: 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 73 65 20 28 (runs:lownoise (
a4d0: 63 6f 6e 63 20 22 46 41 49 4c 45 44 20 70 72 65 conc "FAILED pre
a4e0: 72 65 71 75 69 74 65 73 74 73 20 61 6e 64 20 77 requitests and w
a4f0: 65 20 74 72 69 65 64 22 20 68 65 64 29 20 36 30 e tried" hed) 60
a500: 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ).... (debug:pr
a510: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
a520: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
a530: 20 46 41 49 4c 45 44 20 70 72 65 72 65 71 75 69 FAILED prerequi
a540: 74 65 73 74 73 20 61 6e 64 20 77 65 27 76 65 20 tests and we've
a550: 74 72 69 65 64 20 61 74 20 6c 65 61 73 74 20 31 tried at least 1
a560: 30 20 74 69 6d 65 73 20 74 6f 20 72 75 6e 20 69 0 times to run i
a570: 74 2e 20 47 69 76 69 6e 67 20 75 70 20 6e 6f 77 t. Giving up now
a580: 2e 22 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 ."))... ;;
a590: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
a5a0: 20 20 20 20 20 20 20 20 20 70 72 65 72 65 71 73 prereqs
a5b0: 3a 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d : " prereqs-not-
a5c0: 6d 65 74 29 0a 09 09 20 20 20 20 20 20 28 68 61 met)... (ha
a5d0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
a5e0: 73 74 2d 72 65 67 69 73 74 72 79 20 68 65 64 20 st-registry hed
a5f0: 27 72 65 6d 6f 76 65 64 29 0a 09 09 20 20 20 20 'removed)...
a600: 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (mt:test-set-s
a610: 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 tate-status-by-t
a620: 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 estname run-id t
a630: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
a640: 74 68 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 th "NOT_STARTED"
a650: 20 22 54 45 4e 5f 53 54 52 49 4b 45 53 22 20 23 "TEN_STRIKES" #
a660: 66 29 0a 09 09 20 20 20 20 20 20 28 6d 74 3a 72 f)... (mt:r
a670: 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c oll-up-pass-fail
a680: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
a690: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
a6a0: 74 68 20 22 46 41 49 4c 22 29 20 3b 3b 20 74 72 th "FAIL") ;; tr
a6b0: 65 61 74 20 61 73 20 46 41 49 4c 0a 09 09 20 20 eat as FAIL...
a6c0: 20 20 20 20 28 6c 69 73 74 20 28 69 66 20 28 6e (list (if (n
a6d0: 75 6c 6c 3f 20 74 61 6c 29 28 63 61 72 20 6e 65 ull? tal)(car ne
a6e0: 77 74 61 6c 29 28 63 61 72 20 74 61 6c 29 29 0a wtal)(car tal)).
a6f0: 09 09 09 20 20 20 20 74 61 6c 0a 09 09 09 20 20 ... tal....
a700: 20 20 72 65 67 0a 09 09 09 20 20 20 20 72 65 72 reg.... rer
a710: 75 6e 73 29 29 29 29 29 0a 09 20 20 20 20 20 20 uns)))))..
a720: 3b 3b 20 63 61 6e 27 74 20 64 72 6f 70 20 74 68 ;; can't drop th
a730: 69 73 20 2d 20 6d 61 79 62 65 20 72 75 6e 6e 69 is - maybe runni
a740: 6e 67 3f 20 4a 75 73 74 20 6b 65 65 70 20 74 72 ng? Just keep tr
a750: 79 69 6e 67 0a 09 20 20 20 20 20 20 28 6c 65 74 ying.. (let
a760: 20 28 28 72 75 6e 61 62 6c 65 2d 74 65 73 74 73 ((runable-tests
a770: 20 28 72 75 6e 73 3a 72 75 6e 61 62 6c 65 2d 74 (runs:runable-t
a780: 65 73 74 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 ests prereqs-not
a790: 2d 6d 65 74 29 29 29 0a 09 09 28 69 66 20 28 6e -met)))...(if (n
a7a0: 75 6c 6c 3f 20 72 75 6e 61 62 6c 65 2d 74 65 73 ull? runable-tes
a7b0: 74 73 29 0a 09 09 20 20 20 20 23 66 20 20 20 3b ts)... #f ;
a7c0: 3b 20 49 20 74 68 69 6e 6b 20 77 65 20 61 72 65 ; I think we are
a7d0: 20 74 72 75 6c 79 20 64 6f 6e 65 20 68 65 72 65 truly done here
a7e0: 0a 09 09 20 20 20 20 28 6c 69 73 74 20 28 72 75 ... (list (ru
a7f0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 68 65 ns:queue-next-he
a800: 64 20 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 d newtal reg reg
a810: 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 len regfull)....
a820: 20 20 20 20 28 72 75 6e 73 3a 71 75 65 75 65 2d (runs:queue-
a830: 6e 65 78 74 2d 74 61 6c 20 6e 65 77 74 61 6c 20 next-tal newtal
a840: 72 65 67 20 72 65 67 6c 65 6e 20 72 65 67 66 75 reg reglen regfu
a850: 6c 6c 29 0a 09 09 09 20 20 20 20 28 72 75 6e 73 ll).... (runs
a860: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 20 :queue-next-reg
a870: 6e 65 77 74 61 6c 20 72 65 67 20 72 65 67 6c 65 newtal reg regle
a880: 6e 20 72 65 67 66 75 6c 6c 29 0a 09 09 09 20 20 n regfull)....
a890: 20 20 72 65 72 75 6e 73 29 29 29 29 29 29 29 29 reruns))))))))
a8a0: 29 0a 0a 3b 3b 20 73 63 61 6e 20 61 20 6c 69 73 )..;; scan a lis
a8b0: 74 20 6f 66 20 74 65 73 74 73 20 6c 6f 6f 6b 69 t of tests looki
a8c0: 6e 67 20 74 6f 20 73 65 65 20 69 66 20 61 6e 79 ng to see if any
a8d0: 20 61 72 65 20 70 6f 74 65 6e 74 69 61 6c 6c 79 are potentially
a8e0: 20 72 75 6e 6e 61 62 6c 65 0a 28 64 65 66 69 6e runnable.(defin
a8f0: 65 20 28 72 75 6e 73 3a 72 75 6e 61 62 6c 65 2d e (runs:runable-
a900: 74 65 73 74 73 20 74 65 73 74 73 29 0a 20 20 28 tests tests). (
a910: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
a920: 74 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 t).. (if (not
a930: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 09 (vector? t))...
a940: 74 0a 09 09 28 6c 65 74 20 28 28 73 74 61 74 65 t...(let ((state
a950: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
a960: 74 61 74 65 20 74 29 29 0a 09 09 20 20 20 20 20 tate t))...
a970: 20 28 73 74 61 74 75 73 20 28 64 62 3a 74 65 73 (status (db:tes
a980: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 t-get-status t))
a990: 29 0a 09 09 20 20 28 63 61 73 65 20 28 73 74 72 )... (case (str
a9a0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 ing->symbol stat
a9b0: 65 29 0a 09 09 20 20 20 20 28 28 43 4f 4d 50 4c e)... ((COMPL
a9c0: 45 54 45 44 29 20 23 66 29 0a 09 09 20 20 20 20 ETED) #f)...
a9d0: 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 0a 09 ((NOT_STARTED)..
a9e0: 09 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 . (if (membe
a9f0: 72 20 73 74 61 74 75 73 20 27 28 22 54 45 4e 5f r status '("TEN_
aa00: 53 54 52 49 4b 45 53 22 20 22 42 4c 4f 43 4b 45 STRIKES" "BLOCKE
aa10: 44 22 20 22 50 52 45 51 5f 46 41 49 4c 22 20 22 D" "PREQ_FAIL" "
aa20: 5a 45 52 4f 5f 49 54 45 4d 53 22 20 22 50 52 45 ZERO_ITEMS" "PRE
aa30: 51 5f 44 49 53 43 41 52 44 45 44 22 20 22 54 49 Q_DISCARDED" "TI
aa40: 4d 45 44 5f 4f 55 54 22 20 29 29 0a 09 09 09 20 MED_OUT" ))....
aa50: 23 66 0a 09 09 09 20 74 29 29 0a 09 09 20 20 20 #f.... t))...
aa60: 20 28 28 44 45 4c 45 54 45 44 29 20 23 66 29 0a ((DELETED) #f).
aa70: 09 09 20 20 20 20 28 65 6c 73 65 20 74 29 29 29 .. (else t)))
aa80: 29 29 0a 09 20 20 74 65 73 74 73 29 29 0a 0a 3b )).. tests))..;
aa90: 3b 20 65 76 65 72 79 20 74 69 6d 65 20 74 68 6f ; every time tho
aaa0: 75 67 68 20 74 68 65 20 6c 6f 6f 70 20 69 6e 63 ugh the loop inc
aab0: 72 65 6d 65 6e 74 20 74 68 65 20 74 65 73 74 2f rement the test/
aac0: 69 74 65 6d 70 61 74 74 20 76 61 6c 2e 0a 3b 3b itempatt val..;;
aad0: 20 77 68 65 6e 20 74 68 65 20 6d 69 6e 20 69 73 when the min is
aae0: 20 3e 20 6d 61 78 2d 61 6c 6c 6f 77 65 64 20 61 > max-allowed a
aaf0: 6e 64 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 20 nd none running
ab00: 74 68 65 6e 20 66 6f 72 63 65 20 65 78 69 74 0a then force exit.
ab10: 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d ;;.(define *max-
ab20: 74 72 69 65 73 2d 68 61 73 68 2a 20 28 6d 61 6b tries-hash* (mak
ab30: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a e-hash-table))..
ab40: 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ;; test-records
ab50: 69 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 is a hash table
ab60: 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 testname:item_pa
ab70: 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 th => vector < t
ab80: 65 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 estname testconf
ab90: 69 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 ig waitons prior
aba0: 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e ity items-info .
abb0: 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 .. >.(define (ru
abc0: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 ns:run-tests-que
abd0: 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d ue run-id runnam
abe0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b e test-records k
abf0: 65 79 76 61 6c 73 20 66 6c 61 67 73 20 74 65 73 eyvals flags tes
ac00: 74 2d 70 61 74 74 73 20 72 65 71 75 69 72 65 64 t-patts required
ac10: 2d 74 65 73 74 73 20 72 65 67 6c 65 6e 2d 69 6e -tests reglen-in
ac20: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
ac30: 74 72 79 20 61 72 65 61 2d 64 61 74 29 0a 20 20 try area-dat).
ac40: 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 ;; At this point
ac50: 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 61 72 the list of par
ac60: 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 78 70 ent tests is exp
ac70: 61 6e 64 65 64 20 0a 20 20 3b 3b 20 4e 42 2f 2f anded . ;; NB//
ac80: 20 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 20 69 Should expand i
ac90: 74 65 6d 73 20 68 65 72 65 20 61 6e 64 20 74 68 tems here and th
aca0: 65 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f 20 74 en insert into t
acb0: 68 65 20 72 75 6e 20 71 75 65 75 65 2e 0a 20 20 he run queue..
acc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 (debug:print 5 "
acd0: 74 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 22 20 test-records: "
ace0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 2c 20 test-records ",
acf0: 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 2d 74 flags: " (hash-t
ad00: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 able->alist flag
ad10: 73 29 29 0a 0a 20 20 3b 3b 20 44 6f 20 6d 61 72 s)).. ;; Do mar
ad20: 6b 2d 61 6e 64 2d 66 69 6e 64 20 63 6c 65 61 6e k-and-find clean
ad30: 20 75 70 20 6f 66 20 64 62 20 62 65 66 6f 72 65 up of db before
ad40: 20 73 74 61 72 74 69 6e 67 20 72 75 6e 69 6e 67 starting runing
ad50: 20 6f 66 20 71 75 75 65 0a 20 20 3b 3b 0a 20 20 of quue. ;;.
ad60: 3b 3b 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 ;; (rmt:find-and
ad70: 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 -mark-incomplete
ad80: 29 0a 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e ).. (let* ((con
ad90: 66 69 67 64 61 74 20 20 20 20 20 20 20 20 20 20 figdat
ada0: 20 20 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 (megatest:are
adb0: 61 2d 63 6f 6e 66 69 67 64 61 74 20 61 72 65 61 a-configdat area
adc0: 2d 64 61 74 29 29 0a 09 20 28 74 6f 70 70 61 74 -dat)).. (toppat
add0: 68 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 h
ade0: 28 6d 65 67 61 74 65 73 74 3a 61 72 65 61 2d 70 (megatest:area-p
adf0: 61 74 68 20 20 20 20 20 20 61 72 65 61 2d 64 61 ath area-da
ae00: 74 29 29 0a 09 20 28 72 75 6e 2d 69 6e 66 6f 20 t)).. (run-info
ae10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d (rm
ae20: 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 t:get-run-info r
ae30: 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 29 29 un-id area-dat))
ae40: 0a 09 20 28 74 65 73 74 73 2d 69 6e 66 6f 20 20 .. (tests-info
ae50: 20 20 20 20 20 20 20 20 20 20 28 6d 74 3a 67 65 (mt:ge
ae60: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
ae70: 72 75 6e 2d 69 64 20 23 66 20 27 28 29 20 27 28 run-id #f '() '(
ae80: 29 20 61 72 65 61 2d 64 61 74 29 29 20 3b 3b 20 ) area-dat)) ;;
ae90: 20 71 72 79 76 61 6c 73 3a 20 22 69 64 2c 74 65 qryvals: "id,te
aea0: 73 74 6e 61 6d 65 2c 69 74 65 6d 5f 70 61 74 68 stname,item_path
aeb0: 22 29 29 0a 09 20 28 73 6f 72 74 65 64 2d 74 65 ")).. (sorted-te
aec0: 73 74 2d 6e 61 6d 65 73 20 20 20 20 20 28 74 65 st-names (te
aed0: 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f sts:sort-by-prio
aee0: 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 rity-and-waiton
aef0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
af00: 20 28 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 (test-registry
af10: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
af20: 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 72 65 sh-table)).. (re
af30: 67 69 73 74 72 79 2d 6d 75 74 65 78 20 20 20 20 gistry-mutex
af40: 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 (make-mutex)
af50: 29 0a 09 20 28 6e 75 6d 2d 72 65 74 72 69 65 73 ).. (num-retries
af60: 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 20 0)..
af70: 28 6d 61 78 2d 72 65 74 72 69 65 73 20 20 20 20 (max-retries
af80: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c (config-l
af90: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
afa0: 22 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 "setup" "maxretr
afb0: 69 65 73 22 29 29 0a 09 20 28 6d 61 78 2d 63 6f ies")).. (max-co
afc0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 ncurrent-jobs
afd0: 28 6c 65 74 20 28 28 6d 63 6a 20 28 63 6f 6e 66 (let ((mcj (conf
afe0: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
aff0: 64 61 74 20 22 73 65 74 75 70 22 20 20 20 20 20 dat "setup"
b000: 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f "max_concurrent_
b010: 6a 6f 62 73 22 29 29 29 0a 09 09 09 09 20 20 28 jobs")))..... (
b020: 69 66 20 28 61 6e 64 20 6d 63 6a 20 28 73 74 72 if (and mcj (str
b030: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 ing->number mcj)
b040: 29 0a 09 09 09 09 20 20 20 20 20 20 28 73 74 72 )..... (str
b050: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 ing->number mcj)
b060: 0a 09 09 09 09 20 20 20 20 20 20 31 29 29 29 20 ..... 1)))
b070: 3b 3b 20 6c 65 6e 67 74 68 20 6f 66 20 74 68 65 ;; length of the
b080: 20 72 65 67 69 73 74 65 72 20 71 75 65 75 65 20 register queue
b090: 61 68 65 61 64 0a 09 20 28 72 65 67 6c 65 6e 20 ahead.. (reglen
b0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b0b0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 65 67 6c if (number? regl
b0c0: 65 6e 2d 69 6e 29 20 72 65 67 6c 65 6e 2d 69 6e en-in) reglen-in
b0d0: 20 31 29 29 0a 09 20 28 6c 61 73 74 2d 74 69 6d 1)).. (last-tim
b0e0: 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 20 28 2d e-incomplete (-
b0f0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
b100: 73 29 20 39 30 30 29 29 20 3b 3b 20 66 6f 72 63 s) 900)) ;; forc
b110: 65 20 61 74 20 6c 65 61 73 74 20 6f 6e 65 20 63 e at least one c
b120: 6c 65 61 6e 20 75 70 20 63 79 63 6c 65 0a 09 20 lean up cycle..
b130: 28 6c 61 73 74 2d 74 69 6d 65 2d 73 6f 6d 65 2d (last-time-some-
b140: 72 75 6e 6e 69 6e 67 20 28 63 75 72 72 65 6e 74 running (current
b150: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 74 64 -seconds)).. (td
b160: 62 64 61 74 20 20 20 20 20 20 20 20 20 20 20 20 bdat
b170: 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d (tasks:open-
b180: 64 62 20 61 72 65 61 2d 64 61 74 29 29 29 0a 20 db area-dat))).
b190: 20 20 20 0a 20 20 20 20 3b 3b 20 49 6e 69 74 69 . ;; Initi
b1a0: 61 6c 69 7a 65 20 74 68 65 20 74 65 73 74 2d 72 alize the test-r
b1b0: 65 67 69 73 74 65 72 79 20 68 61 73 68 20 77 69 egistery hash wi
b1c0: 74 68 20 74 65 73 74 73 20 74 68 61 74 20 61 6c th tests that al
b1d0: 72 65 61 64 79 20 68 61 76 65 20 61 20 72 65 63 ready have a rec
b1e0: 6f 72 64 0a 20 20 20 20 3b 3b 20 63 6f 6e 76 65 ord. ;; conve
b1f0: 72 74 20 73 74 61 74 65 20 74 6f 20 73 79 6d 62 rt state to symb
b200: 6f 6c 20 61 6e 64 20 75 73 65 20 74 68 61 74 20 ol and use that
b210: 61 73 20 74 68 65 20 68 61 73 68 20 76 61 6c 75 as the hash valu
b220: 65 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 e. (for-each
b230: 28 6c 61 6d 62 64 61 20 28 74 72 65 63 29 0a 09 (lambda (trec)..
b240: 09 28 6c 65 74 20 28 28 69 64 20 28 64 62 3a 74 .(let ((id (db:t
b250: 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 20 20 est-get-id
b260: 20 20 74 72 65 63 29 29 0a 09 09 20 20 20 20 20 trec))...
b270: 20 28 74 6e 20 28 64 62 3a 74 65 73 74 2d 67 65 (tn (db:test-ge
b280: 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 72 65 63 t-testname trec
b290: 29 29 0a 09 09 20 20 20 20 20 20 28 69 70 20 28 ))... (ip (
b2a0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
b2b0: 2d 70 61 74 68 20 74 72 65 63 29 29 0a 09 09 20 -path trec))...
b2c0: 20 20 20 20 20 28 73 74 20 28 64 62 3a 74 65 73 (st (db:tes
b2d0: 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 20 t-get-state
b2e0: 74 72 65 63 29 29 29 0a 09 09 20 20 28 69 66 20 trec)))... (if
b2f0: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 74 20 (not (equal? st
b300: 22 44 45 4c 45 54 45 44 22 29 29 0a 09 09 20 20 "DELETED"))...
b310: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
b320: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
b330: 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 ry (db:test-make
b340: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 6e 20 69 70 -full-name tn ip
b350: 29 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f ) (string->symbo
b360: 6c 20 73 74 29 29 29 29 29 0a 09 20 20 20 20 20 l st)))))..
b370: 20 74 65 73 74 73 2d 69 6e 66 6f 29 0a 20 20 20 tests-info).
b380: 20 28 73 65 74 21 20 6d 61 78 2d 72 65 74 72 69 (set! max-retri
b390: 65 73 20 28 69 66 20 28 61 6e 64 20 6d 61 78 2d es (if (and max-
b3a0: 72 65 74 72 69 65 73 20 28 73 74 72 69 6e 67 2d retries (string-
b3b0: 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 >number max-retr
b3c0: 69 65 73 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 ies))(string->nu
b3d0: 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 mber max-retries
b3e0: 29 20 31 30 30 29 29 0a 0a 20 20 20 20 28 6c 65 ) 100)).. (le
b3f0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
b400: 20 20 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 (car sorted
b410: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 -test-names))..
b420: 20 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 20 (tal
b430: 20 20 20 28 63 64 72 20 73 6f 72 74 65 64 2d 74 (cdr sorted-t
b440: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 est-names))..
b450: 20 20 20 20 28 72 65 67 20 20 20 20 20 20 20 20 (reg
b460: 20 27 28 29 29 20 3b 3b 20 72 65 67 69 73 74 65 '()) ;; registe
b470: 72 65 64 2c 20 70 75 74 20 74 68 65 73 65 20 61 red, put these a
b480: 74 20 74 68 65 20 68 65 61 64 20 6f 66 20 74 61 t the head of ta
b490: 6c 20 0a 09 20 20 20 20 20 20 20 28 72 65 72 75 l .. (reru
b4a0: 6e 73 20 20 20 20 20 20 27 28 29 29 29 0a 0a 20 ns '()))..
b4b0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n
b4c0: 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 ull? reruns))(de
b4d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
b4e0: 20 22 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e "reruns=" rerun
b4f0: 73 29 29 0a 0a 20 20 20 20 20 20 3b 3b 20 48 65 s)).. ;; He
b500: 72 65 20 77 65 20 6d 61 72 6b 20 61 6e 79 20 6f re we mark any o
b510: 6c 64 20 64 65 66 75 6e 63 74 20 74 65 73 74 73 ld defunct tests
b520: 20 61 73 20 69 6e 63 6f 6d 70 6c 65 74 65 2e 20 as incomplete.
b530: 44 6f 20 74 68 69 73 20 65 76 65 72 79 20 66 69 Do this every fi
b540: 66 74 65 65 6e 20 6d 69 6e 75 74 65 73 0a 20 20 fteen minutes.
b550: 20 20 20 20 3b 3b 20 6d 6f 76 69 6e 67 20 74 68 ;; moving th
b560: 69 73 20 74 6f 20 61 20 70 61 72 61 6c 6c 65 6c is to a parallel
b570: 20 74 68 72 65 61 64 20 61 6e 64 20 6a 75 73 74 thread and just
b580: 20 72 75 6e 20 69 74 20 6f 6e 63 65 2e 0a 20 20 run it once..
b590: 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 28 69 66 ;;. (if
b5a0: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
b5b0: 6f 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d onds)(+ last-tim
b5c0: 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 39 30 30 e-incomplete 900
b5d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 )). (be
b5e0: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
b5f0: 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 2d (set! last-time-
b600: 69 6e 63 6f 6d 70 6c 65 74 65 20 28 63 75 72 72 incomplete (curr
b610: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 ent-seconds)).
b620: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 72 6d ;; (rm
b630: 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d t:find-and-mark-
b640: 69 6e 63 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 incomplete-all-r
b650: 75 6e 73 29 0a 09 20 20 20 20 29 29 0a 0a 20 20 uns).. ))..
b660: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 ;; (print "T
b670: 6f 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d op of loop, hed=
b680: 22 20 68 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 " hed ", tal=" t
b690: 61 6c 20 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 al " ,reruns=" r
b6a0: 65 72 75 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 eruns). (le
b6b0: 74 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 t* ((test-record
b6c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
b6d0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
b6e0: 64 29 29 0a 09 20 20 20 20 20 28 74 65 73 74 2d d)).. (test-
b6f0: 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 65 name (tests:te
b700: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
b710: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
b720: 29 29 0a 09 20 20 20 20 20 28 74 63 6f 6e 66 69 )).. (tconfi
b730: 67 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 g (tests:tes
b740: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 tqueue-get-testc
b750: 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 onfig test-recor
b760: 64 29 29 0a 09 20 20 20 20 20 28 6a 6f 62 67 72 d)).. (jobgr
b770: 6f 75 70 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c oup (config-l
b780: 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 74 ookup tconfig "t
b790: 65 73 74 5f 6d 65 74 61 22 20 22 6a 6f 62 67 72 est_meta" "jobgr
b7a0: 6f 75 70 22 29 29 0a 09 20 20 20 20 20 28 74 65 oup")).. (te
b7b0: 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 stmode (let (
b7c0: 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (m (config-looku
b7d0: 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 p tconfig "requi
b7e0: 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 rements" "mode")
b7f0: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 6d 20 )).... (if m
b800: 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 73 79 6d (map string->sym
b810: 62 6f 6c 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 bol (string-spli
b820: 74 20 6d 29 29 20 27 28 6e 6f 72 6d 61 6c 29 29 t m)) '(normal))
b830: 29 29 0a 09 20 20 20 20 20 28 69 74 65 6d 6d 61 )).. (itemma
b840: 70 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c p (configf:l
b850: 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 ookup tconfig "r
b860: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 equirements" "it
b870: 65 6d 6d 61 70 22 29 29 0a 09 20 20 20 20 20 28 emmap")).. (
b880: 77 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 waitons (tes
b890: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
b8a0: 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 -waitons test
b8b0: 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 -record))..
b8c0: 28 70 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 (priority (te
b8d0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
b8e0: 74 2d 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 t-priority tes
b8f0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
b900: 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 28 74 (itemdat (t
b910: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
b920: 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 et-itemdat te
b930: 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 st-record)) ;; i
b940: 74 65 6d 64 61 74 20 63 61 6e 20 62 65 20 61 20 temdat can be a
b950: 73 74 72 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 string, list or
b960: 23 66 0a 09 20 20 20 20 20 28 69 74 65 6d 73 20 #f.. (items
b970: 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 (tests:tes
b980: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 tqueue-get-items
b990: 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 test-recor
b9a0: 64 29 29 0a 09 20 20 20 20 20 28 69 74 65 6d 2d d)).. (item-
b9b0: 70 61 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 path (item-lis
b9c0: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
b9d0: 29 0a 09 20 20 20 20 20 28 74 66 75 6c 6c 6e 61 ).. (tfullna
b9e0: 6d 65 20 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 me (db:test-ma
b9f0: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
ba00: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
ba10: 29 29 0a 09 20 20 20 20 20 28 6e 65 77 74 61 6c )).. (newtal
ba20: 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 (append ta
ba30: 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 l (list hed)))..
ba40: 20 20 20 20 20 28 72 65 67 66 75 6c 6c 20 20 20 (regfull
ba50: 20 20 28 3e 3d 20 28 6c 65 6e 67 74 68 20 72 65 (>= (length re
ba60: 67 29 20 72 65 67 6c 65 6e 29 29 0a 09 20 20 20 g) reglen))..
ba70: 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 (num-running (
ba80: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
ba90: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
baa0: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 61 72 run-id run-id ar
bab0: 65 61 2d 64 61 74 29 29 29 0a 0a 09 3b 3b 20 65 ea-dat)))...;; e
bac0: 76 65 72 79 20 63 6f 75 70 6c 65 20 6d 69 6e 75 very couple minu
bad0: 74 65 73 20 76 65 72 69 66 79 20 74 68 65 20 73 tes verify the s
bae0: 65 72 76 65 72 20 69 73 20 74 68 65 72 65 20 66 erver is there f
baf0: 6f 72 20 74 68 69 73 20 72 75 6e 0a 09 28 69 66 or this run..(if
bb00: 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f (and (common:lo
bb10: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 36 30 w-noise-print 60
bb20: 20 22 74 72 79 20 73 74 61 72 74 20 73 65 72 76 "try start serv
bb30: 65 72 22 20 20 72 75 6e 2d 69 64 29 0a 09 09 20 er" run-id)...
bb40: 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 76 (tasks:need-serv
bb50: 65 72 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 er run-id area-d
bb60: 61 74 29 29 0a 09 20 20 20 20 28 74 61 73 6b 73 at)).. (tasks
bb70: 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 2d :start-and-wait-
bb80: 66 6f 72 2d 73 65 72 76 65 72 20 74 64 62 64 61 for-server tdbda
bb90: 74 20 72 75 6e 2d 69 64 20 31 30 29 29 20 3b 3b t run-id 10)) ;;
bba0: 20 4e 4f 54 45 3a 20 64 65 6c 61 79 20 61 6e 64 NOTE: delay and
bbb0: 20 77 61 69 74 20 69 73 20 64 6f 6e 65 20 75 6e wait is done un
bbc0: 64 65 72 20 74 68 65 20 68 6f 6f 64 0a 09 0a 09 der the hood....
bbd0: 28 69 66 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 (if (> num-runni
bbe0: 6e 67 20 30 29 0a 09 20 20 28 73 65 74 21 20 6c ng 0).. (set! l
bbf0: 61 73 74 2d 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 ast-time-some-ru
bc00: 6e 6e 69 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 nning (current-s
bc10: 65 63 6f 6e 64 73 29 29 29 0a 0a 20 20 20 20 20 econds)))..
bc20: 20 28 69 66 20 28 3e 20 28 63 75 72 72 65 6e 74 (if (> (current
bc30: 2d 73 65 63 6f 6e 64 73 29 28 2b 20 6c 61 73 74 -seconds)(+ last
bc40: 2d 74 69 6d 65 2d 73 6f 6d 65 2d 72 75 6e 6e 69 -time-some-runni
bc50: 6e 67 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a ng (or (configf:
bc60: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
bc70: 74 2a 20 22 73 65 74 75 70 22 20 22 67 69 76 65 t* "setup" "give
bc80: 2d 75 70 2d 77 61 69 74 69 6e 67 22 29 20 33 36 -up-waiting") 36
bc90: 30 30 30 29 29 29 0a 09 20 20 28 68 61 73 68 2d 000))).. (hash-
bca0: 74 61 62 6c 65 2d 73 65 74 21 20 2a 6d 61 78 2d table-set! *max-
bcb0: 74 72 69 65 73 2d 68 61 73 68 2a 20 74 66 75 6c tries-hash* tful
bcc0: 6c 6e 61 6d 65 20 28 2b 20 28 68 61 73 68 2d 74 lname (+ (hash-t
bcd0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
bce0: 20 2a 6d 61 78 2d 74 72 69 65 73 2d 68 61 73 68 *max-tries-hash
bcf0: 2a 20 74 66 75 6c 6c 6e 61 6d 65 20 30 29 20 31 * tfullname 0) 1
bd00: 29 29 29 0a 09 3b 3b 20 28 64 65 62 75 67 3a 70 )))..;; (debug:p
bd10: 72 69 6e 74 20 30 20 22 6d 61 78 2d 74 72 69 65 rint 0 "max-trie
bd20: 73 2d 68 61 73 68 3a 20 22 20 28 68 61 73 68 2d s-hash: " (hash-
bd30: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 2a 6d 61 table->alist *ma
bd40: 78 2d 74 72 69 65 73 2d 68 61 73 68 2a 29 29 0a x-tries-hash*)).
bd50: 0a 09 3b 3b 20 45 6e 73 75 72 65 20 61 6c 6c 20 ..;; Ensure all
bd60: 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 74 73 20 top level tests
bd70: 67 65 74 20 72 65 67 69 73 74 65 72 65 64 2e 20 get registered.
bd80: 54 68 69 73 20 77 61 79 20 74 68 65 79 20 73 68 This way they sh
bd90: 6f 77 20 75 70 20 61 73 20 22 4e 4f 54 5f 53 54 ow up as "NOT_ST
bda0: 41 52 54 45 44 22 20 6f 6e 20 74 68 65 20 64 61 ARTED" on the da
bdb0: 73 68 62 6f 61 72 64 0a 09 3b 3b 20 61 6e 64 20 shboard..;; and
bdc0: 69 74 20 69 73 20 63 6c 65 61 72 20 74 68 65 79 it is clear they
bdd0: 20 2a 73 68 6f 75 6c 64 2a 20 68 61 76 65 20 72 *should* have r
bde0: 75 6e 20 62 75 74 20 64 69 64 20 6e 6f 74 2e 0a un but did not..
bdf0: 09 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d .(if (not (hash-
be00: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
be10: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
be20: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
be30: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
be40: 65 20 22 22 29 20 23 66 29 29 0a 09 20 20 20 20 e "") #f))..
be50: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 72 (begin.. (r
be60: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
be70: 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 'register-test r
be80: 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 20 72 un-id area-dat r
be90: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
bea0: 22 22 20 61 72 65 61 2d 64 61 74 29 0a 09 20 20 "" area-dat)..
beb0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
bec0: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
bed0: 72 79 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 ry (db:test-make
bee0: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
bef0: 6e 61 6d 65 20 22 22 29 20 27 64 6f 6e 65 29 29 name "") 'done))
bf00: 29 0a 09 0a 09 3b 3b 20 46 61 73 74 20 73 6b 69 )....;; Fast ski
bf10: 70 20 6f 66 20 74 65 73 74 73 20 74 68 61 74 20 p of tests that
bf20: 61 72 65 20 61 6c 72 65 61 64 79 20 22 43 4f 4d are already "COM
bf30: 50 4c 45 54 45 44 22 20 2d 20 4e 4f 21 20 43 61 PLETED" - NO! Ca
bf40: 6e 6e 6f 74 20 64 6f 20 74 68 61 74 20 61 73 20 nnot do that as
bf50: 74 68 65 20 69 74 65 6d 73 20 6d 61 79 20 6e 6f the items may no
bf60: 74 20 68 61 76 65 20 62 65 65 6e 20 65 78 70 61 t have been expa
bf70: 6e 64 65 64 20 79 65 74 20 3a 28 0a 09 3b 3b 0a nded yet :(..;;.
bf80: 09 28 69 66 20 28 6d 65 6d 62 65 72 20 28 68 61 .(if (member (ha
bf90: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
bfa0: 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 ault test-regist
bfb0: 72 79 20 74 66 75 6c 6c 6e 61 6d 65 20 23 66 29 ry tfullname #f)
bfc0: 20 0a 09 09 20 20 20 20 27 28 44 4f 4e 4f 54 52 ... '(DONOTR
bfd0: 55 4e 20 72 65 6d 6f 76 65 64 29 29 20 3b 3b 20 UN removed)) ;;
bfe0: 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e *common:cant-run
bff0: 2d 73 74 61 74 65 73 2d 73 79 6d 2a 29 20 3b 3b -states-sym*) ;;
c000: 20 27 28 43 4f 4d 50 4c 45 54 45 44 20 4b 49 4c '(COMPLETED KIL
c010: 4c 45 44 20 57 41 49 56 45 44 20 55 4e 4b 4e 4f LED WAIVED UNKNO
c020: 57 4e 20 49 4e 43 4f 4d 50 4c 45 54 45 29 29 0a WN INCOMPLETE)).
c030: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
c040: 20 20 20 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 (if (runs:low
c050: 6e 6f 69 73 65 20 28 63 6f 6e 63 20 22 62 65 65 noise (conc "bee
c060: 6e 20 6d 61 72 6b 65 64 20 64 6f 20 6e 6f 74 20 n marked do not
c070: 72 75 6e 20 22 20 74 66 75 6c 6c 6e 61 6d 65 29 run " tfullname)
c080: 20 36 30 29 0a 09 09 20 20 28 64 65 62 75 67 3a 60)... (debug:
c090: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 6b print-info 0 "Sk
c0a0: 69 70 70 69 6e 67 20 74 65 73 74 20 22 20 74 66 ipping test " tf
c0b0: 75 6c 6c 6e 61 6d 65 20 22 20 61 73 20 69 74 20 ullname " as it
c0c0: 68 61 73 20 62 65 65 6e 20 6d 61 72 6b 65 64 20 has been marked
c0d0: 64 6f 20 6e 6f 74 20 72 75 6e 20 64 75 65 20 74 do not run due t
c0e0: 6f 20 62 65 69 6e 67 20 63 6f 6d 70 6c 65 74 65 o being complete
c0f0: 64 20 6f 72 20 6e 6f 74 20 72 75 6e 6e 61 62 6c d or not runnabl
c100: 65 22 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 e")).. (if
c110: 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (or (not (null?
c120: 74 61 6c 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f tal))(not (null?
c130: 20 72 65 67 29 29 29 0a 09 09 20 20 28 6c 6f 6f reg)))... (loo
c140: 70 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 p (runs:queue-ne
c150: 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 72 xt-hed tal reg r
c160: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
c170: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
c180: 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 72 xt-tal tal reg r
c190: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
c1a0: 09 09 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 ..(runs:queue-ne
c1b0: 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 72 xt-reg tal reg r
c1c0: 65 67 6c 65 6e 20 72 65 67 66 75 6c 6c 29 0a 09 eglen regfull)..
c1d0: 09 09 72 65 72 75 6e 73 29 29 29 29 0a 09 09 20 ..reruns))))...
c1e0: 20 3b 3b 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 ;; (loop (car t
c1f0: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 al)(cdr tal) reg
c200: 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 28 64 reruns))))...(d
c210: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 54 4f ebug:print 4 "TO
c220: 50 20 4f 46 20 4c 4f 4f 50 20 3d 3e 20 22 0a 09 P OF LOOP => "..
c230: 09 20 20 20 20 20 22 74 65 73 74 2d 6e 61 6d 65 . "test-name
c240: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 0a 09 09 : " test-name...
c250: 20 20 20 20 20 22 5c 6e 20 20 74 65 73 74 2d 72 "\n test-r
c260: 65 63 6f 72 64 20 20 22 20 74 65 73 74 2d 72 65 ecord " test-re
c270: 63 6f 72 64 0a 09 09 20 20 20 20 20 22 5c 6e 20 cord... "\n
c280: 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 22 20 hed: "
c290: 68 65 64 0a 09 09 20 20 20 20 20 22 5c 6e 20 20 hed... "\n
c2a0: 69 74 65 6d 64 61 74 3a 20 20 20 20 20 22 20 69 itemdat: " i
c2b0: 74 65 6d 64 61 74 0a 09 09 20 20 20 20 20 22 5c temdat... "\
c2c0: 6e 20 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 n items:
c2d0: 22 20 69 74 65 6d 73 0a 09 09 20 20 20 20 20 22 " items... "
c2e0: 5c 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 20 \n item-path:
c2f0: 20 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 20 " item-path...
c300: 20 20 20 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 "\n waitons
c310: 3a 20 20 20 20 20 22 20 77 61 69 74 6f 6e 73 0a : " waitons.
c320: 09 09 20 20 20 20 20 22 5c 6e 20 20 6e 75 6d 2d .. "\n num-
c330: 72 65 74 72 69 65 73 3a 20 22 20 6e 75 6d 2d 72 retries: " num-r
c340: 65 74 72 69 65 73 0a 09 09 20 20 20 20 20 22 5c etries... "\
c350: 6e 20 20 74 61 6c 3a 20 20 20 20 20 20 20 20 20 n tal:
c360: 22 20 74 61 6c 0a 09 09 20 20 20 20 20 22 5c 6e " tal... "\n
c370: 20 20 72 65 72 75 6e 73 3a 20 20 20 20 20 20 22 reruns: "
c380: 20 72 65 72 75 6e 73 0a 09 09 20 20 20 20 20 22 reruns... "
c390: 5c 6e 20 20 72 65 67 66 75 6c 6c 3a 20 20 20 20 \n regfull:
c3a0: 20 22 20 72 65 67 66 75 6c 6c 0a 09 09 20 20 20 " regfull...
c3b0: 20 20 22 5c 6e 20 20 72 65 67 6c 65 6e 3a 20 20 "\n reglen:
c3c0: 20 20 20 20 22 20 72 65 67 6c 65 6e 0a 09 09 20 " reglen...
c3d0: 20 20 20 20 22 5c 6e 20 20 6c 65 6e 67 74 68 20 "\n length
c3e0: 72 65 67 3a 20 20 22 20 28 6c 65 6e 67 74 68 20 reg: " (length
c3f0: 72 65 67 29 0a 09 09 20 20 20 20 20 22 5c 6e 20 reg)... "\n
c400: 20 72 65 67 3a 20 20 20 20 20 20 20 20 20 22 20 reg: "
c410: 72 65 67 29 0a 0a 09 3b 3b 20 63 68 65 63 6b 20 reg)...;; check
c420: 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f for hed in waito
c430: 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 ns => this would
c440: 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 be circular, re
c450: 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 move it and issu
c460: 65 20 61 6e 0a 09 3b 3b 20 65 72 72 6f 72 0a 09 e an..;; error..
c470: 28 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 74 (if (member test
c480: 2d 6e 61 6d 65 20 77 61 69 74 6f 6e 73 29 0a 09 -name waitons)..
c490: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
c4a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
c4b0: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 "ERROR: test "
c4c0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 test-name " has
c4d0: 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 listed itself as
c4e0: 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 a waiton, pleas
c4f0: 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 e correct this!"
c500: 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 77 ).. (set! w
c510: 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c aiton (filter (l
c520: 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 ambda (x)(not (e
c530: 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 qual? x hed))) w
c540: 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 28 63 6f aitons))))...(co
c550: 6e 64 20 0a 09 20 0a 09 20 3b 3b 20 57 65 20 77 nd .. .. ;; We w
c560: 61 6e 74 20 74 6f 20 63 61 74 63 68 20 74 65 73 ant to catch tes
c570: 74 73 20 74 68 61 74 20 68 61 76 65 20 77 61 69 ts that have wai
c580: 74 6f 6e 73 20 74 68 61 74 20 61 72 65 20 4e 4f tons that are NO
c590: 54 20 69 6e 20 74 68 65 20 71 75 65 75 65 20 61 T in the queue a
c5a0: 6e 64 20 64 69 73 63 61 72 64 20 74 68 65 6d 20 nd discard them
c5b0: 49 46 46 20 0a 09 20 3b 3b 20 74 68 65 79 20 68 IFF .. ;; they h
c5c0: 61 76 65 20 62 65 65 6e 20 74 68 72 6f 75 67 68 ave been through
c5d0: 20 74 68 65 20 77 72 69 6e 67 65 72 20 31 30 20 the wringer 10
c5e0: 6f 72 20 6d 6f 72 65 20 74 69 6d 65 73 0a 09 20 or more times..
c5f0: 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 77 61 69 ((and (list? wai
c600: 74 6f 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6e tons).. (n
c610: 6f 74 20 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e ot (null? waiton
c620: 73 29 29 0a 09 20 20 20 20 20 20 20 28 3e 20 28 s)).. (> (
c630: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
c640: 65 66 61 75 6c 74 20 2a 6d 61 78 2d 74 72 69 65 efault *max-trie
c650: 73 2d 68 61 73 68 2a 20 74 66 75 6c 6c 6e 61 6d s-hash* tfullnam
c660: 65 20 30 29 20 31 30 29 0a 09 20 20 20 20 20 20 e 0) 10)..
c670: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 66 69 (not (null? (fi
c680: 6c 74 65 72 0a 09 09 09 20 20 20 20 6e 75 6d 62 lter.... numb
c690: 65 72 3f 0a 09 09 09 20 20 20 20 28 6d 61 70 20 er?.... (map
c6a0: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
c6b0: 0a 09 09 09 09 20 20 20 28 69 66 20 28 61 6e 64 ..... (if (and
c6c0: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 (not (member wa
c6d0: 69 74 6f 6e 20 74 61 6c 29 29 20 20 20 20 20 20 iton tal))
c6e0: 20 20 20 20 20 20 3b 3b 20 74 68 69 73 20 77 61 ;; this wa
c6f0: 69 74 6f 6e 20 69 73 20 6e 6f 74 20 69 6e 20 74 iton is not in t
c700: 68 65 20 6c 69 73 74 20 74 6f 20 62 65 20 74 72 he list to be tr
c710: 69 65 64 20 74 6f 20 72 75 6e 0a 09 09 09 09 09 ied to run......
c720: 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 (not (member
c730: 20 77 61 69 74 6f 6e 20 72 65 72 75 6e 73 29 29 waiton reruns))
c740: 29 0a 09 09 09 09 20 20 20 20 20 20 20 31 0a 09 )..... 1..
c750: 09 09 09 20 20 20 20 20 20 20 23 66 29 29 0a 09 ... #f))..
c760: 09 09 09 20 77 61 69 74 6f 6e 73 29 29 29 29 29 ... waitons)))))
c770: 20 3b 3b 20 63 6f 75 6c 64 20 64 6f 20 74 68 69 ;; could do thi
c780: 73 20 6d 6f 72 65 20 65 6c 65 67 61 6e 74 6c 79 s more elegantly
c790: 20 77 69 74 68 20 61 20 6d 61 72 6b 65 72 2e 2e with a marker..
c7a0: 2e 2e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
c7b0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d nt 0 "WARNING: M
c7c0: 61 72 6b 69 6e 67 20 74 65 73 74 20 22 20 74 66 arking test " tf
c7d0: 75 6c 6c 6e 61 6d 65 20 22 20 61 73 20 6e 6f 74 ullname " as not
c7e0: 20 72 75 6e 6e 61 62 6c 65 2e 20 49 74 20 69 73 runnable. It is
c7f0: 20 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 waiting on test
c800: 73 20 74 68 61 74 20 63 61 6e 6e 6f 74 20 62 65 s that cannot be
c810: 20 72 75 6e 2e 20 47 69 76 69 6e 67 20 75 70 20 run. Giving up
c820: 6e 6f 77 2e 22 29 0a 09 20 20 28 68 61 73 68 2d now.").. (hash-
c830: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
c840: 72 65 67 69 73 74 72 79 20 74 66 75 6c 6c 6e 61 registry tfullna
c850: 6d 65 20 27 72 65 6d 6f 76 65 64 29 29 0a 0a 09 me 'removed))...
c860: 20 3b 3b 20 69 74 65 6d 73 20 69 73 20 23 66 20 ;; items is #f
c870: 74 68 65 6e 20 74 68 65 20 74 65 73 74 20 69 73 then the test is
c880: 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 65 64 ok to be handed
c890: 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 20 28 off to launch (
c8a0: 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 29 0a but not before).
c8b0: 09 20 3b 3b 20 0a 09 20 28 28 6e 6f 74 20 69 74 . ;; .. ((not it
c8c0: 65 6d 73 29 0a 09 20 20 28 64 65 62 75 67 3a 70 ems).. (debug:p
c8d0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 4f 55 54 rint-info 4 "OUT
c8e0: 45 52 20 43 4f 4e 44 3a 20 28 6e 6f 74 20 69 74 ER COND: (not it
c8f0: 65 6d 73 29 22 29 0a 09 20 20 28 69 66 20 28 61 ems)").. (if (a
c900: 6e 64 20 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d nd (not (tests:m
c910: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
c920: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
c930: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
c940: 73 74 2d 72 65 63 6f 72 64 29 20 69 74 65 6d 2d st-record) item-
c950: 70 61 74 68 20 72 65 71 75 69 72 65 64 3a 20 72 path required: r
c960: 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a equired-tests)).
c970: 09 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f .. (not (null?
c980: 20 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 tal))).. (
c990: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
c9a0: 64 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 dr tal) reg reru
c9b0: 6e 73 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6c ns)).. (let ((l
c9c0: 6f 6f 70 2d 6c 69 73 74 20 28 72 75 6e 73 3a 70 oop-list (runs:p
c9d0: 72 6f 63 65 73 73 2d 65 78 70 61 6e 64 65 64 2d rocess-expanded-
c9e0: 74 65 73 74 73 20 68 65 64 20 74 61 6c 20 72 65 tests hed tal re
c9f0: 67 20 72 65 72 75 6e 73 20 72 65 67 6c 65 6e 20 g reruns reglen
ca00: 72 65 67 66 75 6c 6c 20 74 65 73 74 2d 72 65 63 regfull test-rec
ca10: 6f 72 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 ord runname test
ca20: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
ca30: 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e jobgroup max-con
ca40: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 72 75 6e current-jobs run
ca50: 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d -id waitons item
ca60: 2d 70 61 74 68 20 74 65 73 74 6d 6f 64 65 20 74 -path testmode t
ca70: 65 73 74 2d 70 61 74 74 73 20 72 65 71 75 69 72 est-patts requir
ca80: 65 64 2d 74 65 73 74 73 20 74 65 73 74 2d 72 65 ed-tests test-re
ca90: 67 69 73 74 72 79 20 72 65 67 69 73 74 72 79 2d gistry registry-
caa0: 6d 75 74 65 78 20 66 6c 61 67 73 20 6b 65 79 76 mutex flags keyv
cab0: 61 6c 73 20 72 75 6e 2d 69 6e 66 6f 20 6e 65 77 als run-info new
cac0: 74 61 6c 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 tal all-tests-re
cad0: 67 69 73 74 72 79 20 69 74 65 6d 6d 61 70 20 61 gistry itemmap a
cae0: 72 65 61 2d 64 61 74 29 29 29 0a 09 20 20 20 20 rea-dat)))..
caf0: 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 74 20 28 61 (if loop-list (a
cb00: 70 70 6c 79 20 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c pply loop loop-l
cb10: 69 73 74 29 29 29 29 0a 0a 09 20 3b 3b 20 69 74 ist))))... ;; it
cb20: 65 6d 73 20 70 72 6f 63 65 73 73 65 64 20 69 6e ems processed in
cb30: 74 6f 20 61 20 6c 69 73 74 20 62 75 74 20 6e 6f to a list but no
cb40: 74 20 63 61 6d 65 20 69 6e 20 61 73 20 61 20 6c t came in as a l
cb50: 69 73 74 20 62 65 65 6e 20 70 72 6f 63 65 73 73 ist been process
cb60: 65 64 0a 09 20 3b 3b 0a 09 20 28 28 61 6e 64 20 ed.. ;;.. ((and
cb70: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 20 20 (list? items)
cb80: 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b 6e 6f ;; thus we kno
cb90: 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 65 20 w our items are
cba0: 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c 61 74 already calculat
cbb0: 65 64 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 ed.. (not
cbc0: 20 20 69 74 65 6d 64 61 74 29 29 20 20 3b 3b 20 itemdat)) ;;
cbd0: 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 78 70 61 and not yet expa
cbe0: 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 20 6c 69 nded into the li
cbf0: 73 74 20 6f 66 20 74 68 69 6e 67 73 20 74 6f 20 st of things to
cc00: 62 65 20 64 6f 6e 65 0a 09 20 20 28 64 65 62 75 be done.. (debu
cc10: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
cc20: 4f 55 54 45 52 20 43 4f 4e 44 3a 20 28 61 6e 64 OUTER COND: (and
cc30: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6e (list? items)(n
cc40: 6f 74 20 69 74 65 6d 64 61 74 29 29 22 29 0a 09 ot itemdat))")..
cc50: 20 20 3b 3b 20 4d 75 73 74 20 64 65 74 65 72 6d ;; Must determ
cc60: 69 6e 65 20 69 66 20 74 68 65 20 69 74 65 6d 73 ine if the items
cc70: 20 6c 69 73 74 20 69 73 20 76 61 6c 69 64 2e 20 list is valid.
cc80: 44 69 73 63 61 72 64 20 74 68 65 20 74 65 73 74 Discard the test
cc90: 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a 09 if it is not...
cca0: 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 (if (and (list
ccb0: 3f 20 69 74 65 6d 73 29 0a 09 09 20 20 20 28 3e ? items)... (>
ccc0: 20 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 29 20 (length items)
ccd0: 30 29 0a 09 09 20 20 20 28 61 6e 64 20 28 6c 69 0)... (and (li
cce0: 73 74 3f 20 28 63 61 72 20 69 74 65 6d 73 29 29 st? (car items))
ccf0: 0a 09 09 09 28 3e 20 28 6c 65 6e 67 74 68 20 28 ....(> (length (
cd00: 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 29 0a car items)) 0)).
cd10: 09 09 20 20 20 28 64 65 62 75 67 3a 64 65 62 75 .. (debug:debu
cd20: 67 2d 6d 6f 64 65 20 31 29 29 0a 09 20 20 20 20 g-mode 1))..
cd30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
cd40: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 (map (lambda (r
cd50: 6f 77 29 0a 09 09 09 09 20 20 20 20 28 63 6f 6e ow)..... (con
cd60: 63 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 c (string-inters
cd70: 70 65 72 73 65 0a 09 09 09 09 09 20 20 20 28 6d perse...... (m
cd80: 61 70 20 28 6c 61 6d 62 64 61 20 28 76 61 72 76 ap (lambda (varv
cd90: 61 6c 29 0a 09 09 09 09 09 09 20 20 28 73 74 72 al)....... (str
cda0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
cdb0: 76 61 72 76 61 6c 20 22 3d 22 29 29 0a 09 09 09 varval "="))....
cdc0: 09 09 09 72 6f 77 29 0a 09 09 09 09 09 20 20 20 ...row)......
cdd0: 22 20 22 29 0a 09 09 09 09 09 20 20 22 5c 6e 22 " ")...... "\n"
cde0: 29 29 0a 09 09 09 09 20 20 69 74 65 6d 73 29 29 ))..... items))
cdf0: 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 ).. (for-each..
ce00: 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 79 2d 69 (lambda (my-i
ce10: 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 28 6c temdat).. (l
ce20: 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 72 et* ((new-test-r
ce30: 65 63 6f 72 64 20 28 6c 65 74 20 28 28 6e 65 77 ecord (let ((new
ce40: 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 74 73 3a rec (make-tests:
ce50: 74 65 73 74 71 75 65 75 65 29 29 29 0a 09 09 09 testqueue)))....
ce60: 09 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d . (vector-
ce70: 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 6f 72 copy! test-recor
ce80: 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 20 20 d newrec).....
ce90: 20 20 20 20 20 6e 65 77 72 65 63 29 29 0a 09 09 newrec))...
cea0: 20 20 20 20 28 6d 79 2d 69 74 65 6d 2d 70 61 74 (my-item-pat
ceb0: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
cec0: 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 th my-itemdat)))
ced0: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 74 65 .. (if (te
cee0: 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 sts:match test-p
cef0: 61 74 74 73 20 68 65 64 20 6d 79 2d 69 74 65 6d atts hed my-item
cf00: 2d 70 61 74 68 20 72 65 71 75 69 72 65 64 3a 20 -path required:
cf10: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 20 required-tests)
cf20: 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 ;; (patt-list-ma
cf30: 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 tch my-item-path
cf40: 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 20 20 item-patts)
cf50: 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 77 ;; yes, w
cf60: 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 65 73 e want to proces
cf70: 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e 4f 54 s this item, NOT
cf80: 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 6e 65 E: Should not ne
cf90: 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 68 65 ed this check he
cfa0: 72 65 21 0a 09 09 20 20 20 28 6c 65 74 20 28 28 re!... (let ((
cfb0: 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 64 62 3a newtestname (db:
cfc0: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
cfd0: 61 6d 65 20 68 65 64 20 6d 79 2d 69 74 65 6d 2d ame hed my-item-
cfe0: 70 61 74 68 29 29 29 20 20 20 20 3b 3b 20 74 65 path))) ;; te
cff0: 73 74 20 6e 61 6d 65 73 20 61 72 65 20 75 6e 69 st names are uni
d000: 71 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d 65 2f que on testname/
d010: 69 74 65 6d 2d 70 61 74 68 0a 09 09 20 20 20 20 item-path...
d020: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
d030: 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 20 20 20 e-set-items!
d040: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
d050: 20 23 66 29 0a 09 09 20 20 20 20 20 28 74 65 73 #f)... (tes
d060: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 ts:testqueue-set
d070: 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 77 2d -itemdat! new-
d080: 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d 69 test-record my-i
d090: 74 65 6d 64 61 74 29 0a 09 09 20 20 20 20 20 28 temdat)... (
d0a0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
d0b0: 73 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e set-item_path! n
d0c0: 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d ew-test-record m
d0d0: 79 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 y-item-path)...
d0e0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
d0f0: 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 set! test-record
d100: 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 6e 65 s newtestname ne
d110: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 09 w-test-record)..
d120: 09 20 20 20 20 20 28 73 65 74 21 20 74 61 6c 20 . (set! tal
d130: 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 (append tal (lis
d140: 74 20 6e 65 77 74 65 73 74 6e 61 6d 65 29 29 29 t newtestname)))
d150: 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 )))) ;; since th
d160: 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 ese are itemized
d170: 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 create new test
d180: 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f names testname/
d190: 69 74 65 6d 70 61 74 68 0a 09 20 20 20 69 74 65 itempath.. ite
d1a0: 6d 73 29 0a 0a 09 20 20 3b 3b 20 28 64 65 62 75 ms)... ;; (debu
d1b0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
d1c0: 54 65 73 74 20 22 20 28 74 65 73 74 73 3a 74 65 Test " (tests:te
d1d0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
d1e0: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
d1f0: 29 20 22 20 69 73 20 69 74 65 6d 69 7a 65 64 20 ) " is itemized
d200: 62 75 74 20 68 61 73 20 6e 6f 20 69 74 65 6d 73 but has no items
d210: 22 29 0a 0a 09 20 20 3b 3b 20 41 74 20 74 68 69 ")... ;; At thi
d220: 73 20 70 6f 69 6e 74 20 77 65 20 68 61 76 65 20 s point we have
d230: 70 6f 73 73 69 62 6c 79 20 61 64 64 65 64 20 69 possibly added i
d240: 74 65 6d 73 20 74 6f 20 74 61 6c 20 62 75 74 20 tems to tal but
d250: 61 6c 6c 20 6d 75 73 74 20 62 65 20 68 61 6e 64 all must be hand
d260: 65 64 20 6f 66 66 20 74 6f 20 0a 09 20 20 3b 3b ed off to .. ;;
d270: 20 49 4e 4e 45 52 20 43 4f 4e 44 20 6c 6f 67 69 INNER COND logi
d280: 63 2e 20 49 20 74 68 69 6e 6b 20 6c 6f 6f 70 20 c. I think loop
d290: 77 69 74 68 6f 75 74 20 72 6f 74 61 74 69 6e 67 without rotating
d2a0: 20 74 68 65 20 71 75 65 75 65 20 0a 09 20 20 3b the queue .. ;
d2b0: 3b 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 ; (loop hed tal
d2c0: 72 65 67 20 72 65 72 75 6e 73 29 29 0a 09 20 20 reg reruns))..
d2d0: 3b 3b 20 28 6c 65 74 20 28 28 6e 65 77 74 61 6c ;; (let ((newtal
d2e0: 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 (append tal (li
d2f0: 73 74 20 68 65 64 29 29 29 29 20 20 3b 3b 20 57 st hed)))) ;; W
d300: 65 20 73 68 6f 75 6c 64 20 64 69 73 63 61 72 64 e should discard
d310: 20 68 65 64 20 61 73 20 69 74 20 68 61 73 20 62 hed as it has b
d320: 65 65 6e 20 65 78 70 61 6e 64 65 64 20 69 6e 74 een expanded int
d330: 6f 20 69 74 27 73 20 69 74 65 6d 73 3f 20 59 65 o it's items? Ye
d340: 73 2c 20 62 75 74 20 6f 6e 6c 79 20 69 66 20 74 s, but only if t
d350: 68 69 73 20 2a 69 73 2a 20 61 6e 20 69 74 65 6d his *is* an item
d360: 69 7a 65 64 20 74 65 73 74 0a 09 20 20 3b 3b 20 ized test.. ;;
d370: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
d380: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
d390: 65 67 20 72 65 72 75 6e 73 29 0a 09 20 20 28 69 eg reruns).. (i
d3a0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 f (null? tal)..
d3b0: 20 20 20 20 20 23 66 0a 09 20 20 20 20 20 20 28 #f.. (
d3c0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
d3d0: 64 72 20 74 61 6c 29 20 72 65 67 20 72 65 72 75 dr tal) reg reru
d3e0: 6e 73 29 29 29 0a 09 20 20 20 20 0a 09 20 3b 3b ns))).. .. ;;
d3f0: 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 20 70 if items is a p
d400: 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 74 6f roc then need to
d410: 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 2d 69 run items:get-i
d420: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
d430: 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 20 61 , get the list a
d440: 6e 64 20 6c 6f 6f 70 20 0a 09 20 3b 3b 20 20 20 nd loop .. ;;
d450: 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 74 - but only do t
d460: 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 73 hat if resources
d470: 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 6f exist to kick o
d480: 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 3b 3b 20 ff the job.. ;;
d490: 45 58 50 41 4e 44 20 49 54 45 4d 53 0a 09 20 28 EXPAND ITEMS.. (
d4a0: 28 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (or (procedure?
d4b0: 69 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 items)(eq? items
d4c0: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
d4d0: 29 29 0a 09 20 20 28 6c 65 74 20 28 28 63 61 6e )).. (let ((can
d4e0: 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 72 75 -run-more (ru
d4f0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
d500: 74 65 73 74 73 20 72 75 6e 2d 69 64 20 6a 6f 62 tests run-id job
d510: 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 group max-concur
d520: 72 65 6e 74 2d 6a 6f 62 73 20 61 72 65 61 2d 64 rent-jobs area-d
d530: 61 74 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 at))).. (if (
d540: 61 6e 64 20 28 6c 69 73 74 3f 20 63 61 6e 2d 72 and (list? can-r
d550: 75 6e 2d 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 un-more)...
d560: 28 63 61 72 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 (car can-run-mor
d570: 65 29 29 0a 09 09 28 6c 65 74 20 28 28 6c 6f 6f e))...(let ((loo
d580: 70 2d 6c 69 73 74 20 28 72 75 6e 73 3a 65 78 70 p-list (runs:exp
d590: 61 6e 64 2d 69 74 65 6d 73 20 68 65 64 20 74 61 and-items hed ta
d5a0: 6c 20 72 65 67 20 72 65 72 75 6e 73 20 72 65 67 l reg reruns reg
d5b0: 66 75 6c 6c 20 6e 65 77 74 61 6c 20 6a 6f 62 67 full newtal jobg
d5c0: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
d5d0: 65 6e 74 2d 6a 6f 62 73 20 72 75 6e 2d 69 64 20 ent-jobs run-id
d5e0: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
d5f0: 68 20 74 65 73 74 6d 6f 64 65 20 74 65 73 74 2d h testmode test-
d600: 72 65 63 6f 72 64 20 63 61 6e 2d 72 75 6e 2d 6d record can-run-m
d610: 6f 72 65 20 69 74 65 6d 73 20 72 75 6e 6e 61 6d ore items runnam
d620: 65 20 74 63 6f 6e 66 69 67 20 72 65 67 6c 65 6e e tconfig reglen
d630: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 test-registry t
d640: 65 73 74 2d 72 65 63 6f 72 64 73 20 69 74 65 6d est-records item
d650: 6d 61 70 20 61 72 65 61 2d 64 61 74 29 29 29 0a map area-dat))).
d660: 09 09 20 20 28 69 66 20 6c 6f 6f 70 2d 6c 69 73 .. (if loop-lis
d670: 74 0a 09 09 20 20 20 20 20 20 28 61 70 70 6c 79 t... (apply
d680: 20 6c 6f 6f 70 20 6c 6f 6f 70 2d 6c 69 73 74 29 loop loop-list)
d690: 29 29 0a 09 09 3b 3b 20 69 66 20 63 61 6e 27 74 ))...;; if can't
d6a0: 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 6c run more just l
d6b0: 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 20 70 6f oop with next po
d6c0: 73 73 69 62 6c 65 20 74 65 73 74 0a 09 09 28 6c ssible test...(l
d6d0: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
d6e0: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 (cdr newtal) reg
d6f0: 20 72 65 72 75 6e 73 29 29 29 29 0a 09 20 20 20 reruns))))..
d700: 20 0a 09 20 3b 3b 20 74 68 69 73 20 63 61 73 65 .. ;; this case
d710: 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 70 should not happ
d720: 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 65 6c en, added to hel
d730: 70 20 63 61 74 63 68 20 61 6e 79 20 62 75 67 73 p catch any bugs
d740: 0a 09 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 .. ((and (list?
d750: 69 74 65 6d 73 29 20 69 74 65 6d 64 61 74 29 0a items) itemdat).
d760: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
d770: 30 20 22 45 52 52 4f 52 3a 20 53 68 6f 75 6c 64 0 "ERROR: Should
d780: 20 6e 6f 74 20 68 61 76 65 20 61 20 6c 69 73 74 not have a list
d790: 20 6f 66 20 69 74 65 6d 73 20 69 6e 20 61 20 74 of items in a t
d7a0: 65 73 74 20 61 6e 64 20 74 68 65 20 69 74 65 6d est and the item
d7b0: 73 70 61 74 68 20 73 65 74 20 2d 20 70 6c 65 61 spath set - plea
d7c0: 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 se report this")
d7d0: 0a 09 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 .. (exit 1))..
d7e0: 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 ((not (null? rer
d7f0: 75 6e 73 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 uns)).. (let* (
d800: 28 6e 65 77 6c 73 74 20 28 74 65 73 74 73 3a 66 (newlst (tests:f
d810: 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 ilter-non-runnab
d820: 6c 65 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 le run-id tal te
d830: 73 74 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 st-records)) ;;
d840: 69 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 i.e. not FAIL, W
d850: 41 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 AIVED, INCOMPLET
d860: 45 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c E, PASS, KILLED,
d870: 0a 09 09 20 28 6a 75 6e 6b 65 64 20 28 6c 73 65 ... (junked (lse
d880: 74 2d 64 69 66 66 65 72 65 6e 63 65 20 65 71 75 t-difference equ
d890: 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 74 29 29 al? tal newlst))
d8a0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
d8b0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 66 75 6c 6c int-info 4 "full
d8c0: 20 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 69 drop through, i
d8d0: 66 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 73 f reruns is less
d8e0: 20 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 6c than 100 we wil
d8f0: 6c 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 68 l force retry th
d900: 65 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 72 em, reruns=" rer
d910: 75 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c uns ", tal=" tal
d920: 29 0a 09 20 20 20 20 28 69 66 20 28 3c 20 6e 75 ).. (if (< nu
d930: 6d 2d 72 65 74 72 69 65 73 20 6d 61 78 2d 72 65 m-retries max-re
d940: 74 72 69 65 73 29 0a 09 09 28 73 65 74 21 20 6e tries)...(set! n
d950: 65 77 6c 73 74 20 28 61 70 70 65 6e 64 20 72 65 ewlst (append re
d960: 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 0a 09 runs newlst)))..
d970: 20 20 20 20 28 73 65 74 21 20 6e 75 6d 2d 72 65 (set! num-re
d980: 74 72 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 tries (+ num-ret
d990: 72 69 65 73 20 31 29 29 0a 09 20 20 20 20 3b 3b ries 1)).. ;;
d9a0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
d9b0: 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c (+ 1 *global-del
d9c0: 74 61 2a 29 29 0a 09 20 20 20 20 28 69 66 20 28 ta*)).. (if (
d9d0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 not (null? newls
d9e0: 74 29 29 0a 09 09 3b 3b 20 73 69 6e 63 65 20 72 t))...;; since r
d9f0: 65 72 75 6e 73 20 68 61 76 65 20 62 65 65 6e 20 eruns have been
da00: 74 61 63 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 tacked on to new
da10: 6c 73 74 20 63 72 65 61 74 65 20 6e 65 77 20 72 lst create new r
da20: 65 72 75 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 eruns from junke
da30: 64 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e d...(loop (car n
da40: 65 77 6c 73 74 29 28 63 64 72 20 6e 65 77 6c 73 ewlst)(cdr newls
da50: 74 29 20 72 65 67 20 28 64 65 6c 65 74 65 2d 64 t) reg (delete-d
da60: 75 70 6c 69 63 61 74 65 73 20 6a 75 6e 6b 65 64 uplicates junked
da70: 29 29 29 29 29 0a 09 20 28 28 6e 6f 74 20 28 6e ))))).. ((not (n
da80: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 28 64 ull? tal)).. (d
da90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
daa0: 34 20 22 49 27 6d 20 70 72 65 74 74 79 20 73 75 4 "I'm pretty su
dab0: 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 20 67 re I shouldn't g
dac0: 65 74 20 68 65 72 65 2e 22 29 29 0a 09 20 28 28 et here.")).. ((
dad0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 67 29 29 not (null? reg))
dae0: 20 3b 3b 20 63 6f 75 6c 64 20 77 65 20 67 65 74 ;; could we get
daf0: 20 68 65 72 65 20 77 69 74 68 20 6c 65 66 74 6f here with lefto
db00: 76 65 72 73 3f 0a 09 20 20 28 64 65 62 75 67 3a vers?.. (debug:
db10: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 48 61 print-info 0 "Ha
db20: 76 65 20 6c 65 66 74 6f 76 65 72 73 21 22 29 0a ve leftovers!").
db30: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 . (loop (car re
db40: 67 29 28 63 64 72 20 72 65 67 29 20 27 28 29 20 g)(cdr reg) '()
db50: 72 65 72 75 6e 73 29 29 0a 09 20 28 65 6c 73 65 reruns)).. (else
db60: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
db70: 2d 69 6e 66 6f 20 34 20 22 45 78 69 74 69 6e 67 -info 4 "Exiting
db80: 20 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e 20 loop with...\n
db90: 20 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 hed=" hed "\n
dba0: 74 61 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 20 72 tal=" tal "\n r
dbb0: 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 eruns=" reruns))
dbc0: 0a 09 20 29 29 29 0a 20 20 20 20 3b 3b 20 6e 6f .. ))). ;; no
dbd0: 77 20 2a 69 66 2a 20 2d 72 75 6e 2d 77 61 69 74 w *if* -run-wait
dbe0: 20 77 65 20 77 61 69 74 20 66 6f 72 20 61 6c 6c we wait for all
dbf0: 20 74 65 73 74 73 20 74 6f 20 62 65 20 64 6f 6e tests to be don
dc00: 65 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 77 61 69 e. ;; Now wai
dc10: 74 20 66 6f 72 20 61 6e 79 20 52 55 4e 4e 49 4e t for any RUNNIN
dc20: 47 20 74 65 73 74 73 20 74 6f 20 63 6f 6d 70 6c G tests to compl
dc30: 65 74 65 20 28 69 66 20 69 6e 20 72 75 6e 2d 77 ete (if in run-w
dc40: 61 69 74 20 6d 6f 64 65 29 0a 20 20 20 20 28 6c ait mode). (l
dc50: 65 74 20 77 61 69 74 2d 6c 6f 6f 70 20 28 28 6e et wait-loop ((n
dc60: 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 um-running
dc70: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
dc80: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
dc90: 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 61 -run-id run-id a
dca0: 72 65 61 2d 64 61 74 29 29 0a 09 09 20 20 20 20 rea-dat))...
dcb0: 28 70 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e (prev-num-runnin
dcc0: 67 20 30 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 g 0)). ;; (
dcd0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 6e debug:print 0 "n
dce0: 75 6d 2d 72 75 6e 6e 69 6e 67 3d 22 20 6e 75 6d um-running=" num
dcf0: 2d 72 75 6e 6e 69 6e 67 20 22 2c 20 70 72 65 76 -running ", prev
dd00: 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3d 22 20 70 -num-running=" p
dd10: 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 rev-num-running)
dd20: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
dd30: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
dd40: 67 20 22 2d 72 75 6e 2d 77 61 69 74 22 29 0a 09 g "-run-wait")..
dd50: 09 20 20 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e . (equal? (con
dd60: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 figf:lookup conf
dd70: 69 67 64 61 74 20 22 73 65 74 75 70 22 20 22 72 igdat "setup" "r
dd80: 75 6e 2d 77 61 69 74 22 29 20 22 79 65 73 22 29 un-wait") "yes")
dd90: 29 0a 09 20 20 20 20 20 20 20 28 3e 20 6e 75 6d ).. (> num
dda0: 2d 72 75 6e 6e 69 6e 67 20 30 29 29 0a 09 20 20 -running 0))..
ddb0: 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b 20 48 (begin.. ;; H
ddc0: 65 72 65 20 77 65 20 6d 61 72 6b 20 61 6e 79 20 ere we mark any
ddd0: 6f 6c 64 20 64 65 66 75 6e 63 74 20 74 65 73 74 old defunct test
dde0: 73 20 61 73 20 69 6e 63 6f 6d 70 6c 65 74 65 2e s as incomplete.
ddf0: 20 44 6f 20 74 68 69 73 20 65 76 65 72 79 20 66 Do this every f
de00: 69 66 74 65 65 6e 20 6d 69 6e 75 74 65 73 0a 09 ifteen minutes..
de10: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
de20: 69 6e 74 20 30 20 22 47 6f 74 20 68 65 72 65 20 int 0 "Got here
de30: 65 68 21 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3d eh! num-running=
de40: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 22 20 " num-running "
de50: 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 30 (> num-running 0
de60: 29 20 22 20 28 3e 20 6e 75 6d 2d 72 75 6e 6e 69 ) " (> num-runni
de70: 6e 67 20 30 29 29 0a 09 20 20 20 20 28 69 66 20 ng 0)).. (if
de80: 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (> (current-seco
de90: 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 nds)(+ last-time
dea0: 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 39 30 30 29 -incomplete 900)
deb0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
dec0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
ded0: 20 30 20 22 4d 61 72 6b 69 6e 67 20 73 74 75 63 0 "Marking stuc
dee0: 6b 20 74 65 73 74 73 20 61 73 20 49 4e 43 4f 4d k tests as INCOM
def0: 50 4c 45 54 45 20 77 68 69 6c 65 20 77 61 69 74 PLETE while wait
df00: 69 6e 67 20 66 6f 72 20 72 75 6e 20 22 20 72 75 ing for run " ru
df10: 6e 2d 69 64 20 22 2e 20 52 75 6e 6e 69 6e 67 20 n-id ". Running
df20: 61 73 20 70 69 64 20 22 20 28 63 75 72 72 65 6e as pid " (curren
df30: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 20 t-process-id) "
df40: 6f 6e 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e on " (get-host-n
df50: 61 6d 65 29 29 0a 09 09 20 20 28 73 65 74 21 20 ame))... (set!
df60: 6c 61 73 74 2d 74 69 6d 65 2d 69 6e 63 6f 6d 70 last-time-incomp
df70: 6c 65 74 65 20 28 63 75 72 72 65 6e 74 2d 73 65 lete (current-se
df80: 63 6f 6e 64 73 29 29 0a 09 09 20 20 28 72 6d 74 conds))... (rmt
df90: 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 :find-and-mark-i
dfa0: 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 ncomplete run-id
dfb0: 20 23 66 20 61 72 65 61 2d 64 61 74 29 29 29 0a #f area-dat))).
dfc0: 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
dfd0: 71 3f 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 70 q? num-running p
dfe0: 72 65 76 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 rev-num-running)
dff0: 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
e000: 2d 69 6e 66 6f 20 30 20 22 72 75 6e 2d 77 61 69 -info 0 "run-wai
e010: 74 20 73 70 65 63 69 66 69 65 64 2c 20 77 61 69 t specified, wai
e020: 74 69 6e 67 20 6f 6e 20 22 20 6e 75 6d 2d 72 75 ting on " num-ru
e030: 6e 6e 69 6e 67 20 22 20 74 65 73 74 73 20 69 6e nning " tests in
e040: 20 52 55 4e 4e 49 4e 47 2c 20 52 45 4d 4f 54 45 RUNNING, REMOTE
e050: 48 4f 53 54 53 54 41 52 54 20 6f 72 20 4c 41 55 HOSTSTART or LAU
e060: 4e 43 48 45 44 20 73 74 61 74 65 20 61 74 20 22 NCHED state at "
e070: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 (time->string (
e080: 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
e090: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
e0a0: 6f 6e 64 73 29 29 29 29 29 0a 09 20 20 20 20 28 onds))))).. (
e0b0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 thread-sleep! 5)
e0c0: 0a 09 20 20 20 20 3b 3b 20 28 77 61 69 74 2d 6c .. ;; (wait-l
e0d0: 6f 6f 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 oop (rmt:get-cou
e0e0: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
e0f0: 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d -for-run-id run-
e100: 69 64 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 id) num-running)
e110: 29 29 29 0a 09 20 20 20 20 28 77 61 69 74 2d 6c ))).. (wait-l
e120: 6f 6f 70 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 oop (rmt:get-cou
e130: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
e140: 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d -for-run-id run-
e150: 69 64 20 61 72 65 61 2d 64 61 74 29 20 6e 75 6d id area-dat) num
e160: 2d 72 75 6e 6e 69 6e 67 29 29 29 29 0a 20 20 20 -running)))).
e170: 20 3b 3b 20 4c 45 54 2a 20 28 28 74 65 73 74 2d ;; LET* ((test-
e180: 72 65 63 6f 72 64 0a 20 20 20 20 3b 3b 20 77 65 record. ;; we
e190: 20 67 65 74 20 68 65 72 65 20 6f 6e 20 22 64 72 get here on "dr
e1a0: 6f 70 20 74 68 72 6f 75 67 68 22 2e 20 41 6c 6c op through". All
e1b0: 20 64 6f 6e 65 21 0a 20 20 20 20 28 64 65 62 75 done!. (debu
e1c0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
e1d0: 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 68 All tests launch
e1e0: 65 64 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ed")))..(define
e1f0: 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 (runs:calc-fails
e200: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
e210: 29 0a 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ). (filter (lam
e220: 62 64 61 20 28 74 65 73 74 29 0a 09 20 20 20 20 bda (test)..
e230: 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 65 (and (vector? te
e240: 73 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 st) ;; not (stri
e250: 6e 67 3f 20 74 65 73 74 29 29 0a 09 09 20 28 65 ng? test))... (e
e260: 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 qual? (db:test-g
e270: 65 74 2d 73 74 61 74 65 20 74 65 73 74 29 20 22 et-state test) "
e280: 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 20 28 COMPLETED")... (
e290: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 3a not (member (db:
e2a0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
e2b0: 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 20 27 test).... '
e2c0: 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
e2d0: 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 20 CHECK" "WAIVED"
e2e0: 22 53 4b 49 50 22 29 29 29 29 29 0a 09 20 20 70 "SKIP"))))).. p
e2f0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
e300: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
e310: 63 61 6c 63 2d 70 72 65 72 65 71 2d 66 61 69 6c calc-prereq-fail
e320: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
e330: 29 0a 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ). (filter (lam
e340: 62 64 61 20 28 74 65 73 74 29 0a 09 20 20 20 20 bda (test)..
e350: 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 65 (and (vector? te
e360: 73 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 st) ;; not (stri
e370: 6e 67 3f 20 74 65 73 74 29 29 0a 09 09 20 28 65 ng? test))... (e
e380: 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 qual? (db:test-g
e390: 65 74 2d 73 74 61 74 65 20 74 65 73 74 29 20 22 et-state test) "
e3a0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 09 NOT_STARTED")...
e3b0: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 (not (member (d
e3c0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
e3d0: 73 20 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 s test)....
e3e0: 20 27 28 22 6e 2f 61 22 20 22 4b 45 45 50 5f 54 '("n/a" "KEEP_T
e3f0: 52 59 49 4e 47 22 29 29 29 29 29 0a 09 20 20 70 RYING"))))).. p
e400: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
e410: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
e420: 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 calc-not-complet
e430: 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ed prereqs-not-m
e440: 65 74 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 20 et). (filter.
e450: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 20 (lambda (t).
e460: 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 (or (not (vect
e470: 6f 72 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 28 or? t)).. (not (
e480: 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 equal? "COMPLETE
e490: 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d D" (db:test-get-
e4a0: 73 74 61 74 65 20 74 29 29 29 29 29 0a 20 20 20 state t))))).
e4b0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
e4c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
e4d0: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
e4e0: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
e4f0: 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 met). (filter.
e500: 20 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 (lambda (t).
e510: 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 (or (not (vec
e520: 74 6f 72 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 tor? t)).. (not
e530: 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 (equal? "COMPLET
e540: 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ED" (db:test-get
e550: 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a 20 20 -state t))))).
e560: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
e570: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
e580: 73 3a 63 61 6c 63 2d 72 75 6e 6e 61 62 6c 65 20 s:calc-runnable
e590: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
e5a0: 0a 20 20 28 66 69 6c 74 65 72 20 0a 20 20 20 28 . (filter . (
e5b0: 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 lambda (t).
e5c0: 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 (or (not (vector
e5d0: 3f 20 74 29 29 0a 09 20 28 61 6e 64 20 28 65 71 ? t)).. (and (eq
e5e0: 75 61 6c 3f 20 22 4e 4f 54 5f 53 54 41 52 54 45 ual? "NOT_STARTE
e5f0: 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d D" (db:test-get-
e600: 73 74 61 74 65 20 74 29 29 0a 09 20 20 20 20 20 state t))..
e610: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
e620: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 0a t-get-status t).
e630: 09 09 09 20 20 20 20 20 20 27 28 22 6e 2f 61 22 ... '("n/a"
e640: 20 22 4b 45 45 50 5f 54 52 59 49 4e 47 22 29 29 "KEEP_TRYING"))
e650: 29 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e ))). prereqs-n
e660: 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e ot-met))..(defin
e670: 65 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 e (runs:pretty-s
e680: 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 tring lst). (ma
e690: 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 p (lambda (t)..
e6a0: 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 (if (not (vector
e6b0: 3f 20 74 29 29 0a 09 20 20 20 20 20 28 63 6f 6e ? t)).. (con
e6c0: 63 20 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 c t).. (conc
e6d0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
e6e0: 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 stname t) ":" (d
e6f0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
e700: 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 t) "/" (db:test
e710: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 -get-status t)))
e720: 29 0a 20 20 20 20 20 20 20 6c 73 74 29 29 0a 0a ). lst))..
e730: 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 ;; parent-test i
e740: 73 20 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 s there as a pla
e750: 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 ceholder for whe
e760: 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 n parent-tests c
e770: 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 an be run as a s
e780: 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e etup step.(defin
e790: 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d e (run:test run-
e7a0: 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 id run-info keyv
e7b0: 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 als runname test
e7c0: 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 70 61 -record flags pa
e7d0: 72 65 6e 74 2d 74 65 73 74 20 74 65 73 74 2d 72 rent-test test-r
e7e0: 65 67 69 73 74 72 79 20 61 6c 6c 2d 74 65 73 74 egistry all-test
e7f0: 73 2d 72 65 67 69 73 74 72 79 20 61 72 65 61 2d s-registry area-
e800: 64 61 74 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 dat). ;; All th
e810: 65 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 62 ese vars might b
e820: 65 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 20 e referenced by
e830: 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 the testconfig f
e840: 69 6c 65 20 72 65 61 64 65 72 0a 20 20 28 6c 65 ile reader. (le
e850: 74 2a 20 28 28 74 6f 70 70 61 74 68 20 20 20 20 t* ((toppath
e860: 20 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 61 (megatest:area
e870: 2d 70 61 74 68 20 61 72 65 61 2d 64 61 74 29 29 -path area-dat))
e880: 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 .. (test-name
e890: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
e8a0: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
e8b0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
e8c0: 20 28 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 (test-waitons (
e8d0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
e8e0: 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 get-waitons t
e8f0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
e900: 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 test-conf (te
e910: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
e920: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 t-testconfig tes
e930: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 t-record)).. (it
e940: 65 6d 64 61 74 20 20 20 20 20 20 28 74 65 73 74 emdat (test
e950: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
e960: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
e970: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
e980: 2d 70 61 74 68 20 20 20 20 28 68 61 73 68 2d 74 -path (hash-t
e990: 61 62 6c 65 2d 72 65 66 20 61 6c 6c 2d 74 65 73 able-ref all-tes
e9a0: 74 73 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 ts-registry test
e9b0: 2d 6e 61 6d 65 29 29 0a 09 20 28 66 6f 72 63 65 -name)).. (force
e9c0: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
e9d0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
e9e0: 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 flags "-force" #
e9f0: 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 f)).. (rerun
ea00: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
ea10: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
ea20: 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a s "-rerun" #f)).
ea30: 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 . (keepgoing
ea40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
ea50: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
ea60: 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a keepgoing" #f)).
ea70: 09 20 28 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 69 . (incomplete-ti
ea80: 6d 65 6f 75 74 20 28 73 74 72 69 6e 67 2d 3e 6e meout (string->n
ea90: 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 umber (or (confi
eaa0: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
eab0: 64 61 74 20 22 73 65 74 75 70 22 20 22 69 6e 63 dat "setup" "inc
eac0: 6f 6d 70 6c 65 74 65 2d 74 69 6d 65 6f 75 74 22 omplete-timeout"
ead0: 29 20 22 78 22 29 29 29 0a 09 20 28 69 74 65 6d ) "x"))).. (item
eae0: 2d 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 20 -path "")..
eaf0: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 (db #f
eb00: 29 0a 09 20 28 66 75 6c 6c 2d 74 65 73 74 2d 6e ).. (full-test-n
eb10: 61 6d 65 20 23 66 29 29 0a 0a 20 20 20 20 3b 3b ame #f)).. ;;
eb20: 20 73 65 74 74 69 6e 67 20 69 74 65 6d 64 61 74 setting itemdat
eb30: 20 74 6f 20 61 20 6c 69 73 74 20 69 66 20 69 74 to a list if it
eb40: 20 69 73 20 23 66 0a 20 20 20 20 28 69 66 20 28 is #f. (if (
eb50: 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 73 65 74 not itemdat)(set
eb60: 21 20 69 74 65 6d 64 61 74 20 27 28 29 29 29 0a ! itemdat '())).
eb70: 20 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d 70 (set! item-p
eb80: 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e ath (item-list->
eb90: 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 20 path itemdat)).
eba0: 20 20 20 28 73 65 74 21 20 66 75 6c 6c 2d 74 65 (set! full-te
ebb0: 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 st-name (db:test
ebc0: 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
ebd0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
ebe0: 61 74 68 29 29 0a 20 20 20 20 28 64 65 62 75 67 ath)). (debug
ebf0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 0a 09 09 :print-info 4...
ec00: 20 20 20 20 20 20 22 5c 6e 54 45 53 54 4e 41 4d "\nTESTNAM
ec10: 45 3a 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e E: " full-test-n
ec20: 61 6d 65 20 0a 09 09 20 20 20 20 20 20 22 5c 6e ame ... "\n
ec30: 20 20 20 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 test-config:
ec40: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
ec50: 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a list test-conf).
ec60: 09 09 20 20 20 20 20 20 22 5c 6e 20 20 20 69 74 .. "\n it
ec70: 65 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 74 emdat: " itemdat
ec80: 0a 09 09 20 20 20 20 20 20 29 0a 20 20 20 20 28 ... ). (
ec90: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 41 debug:print 2 "A
eca0: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 ttempting to lau
ecb0: 6e 63 68 20 74 65 73 74 20 22 20 66 75 6c 6c 2d nch test " full-
ecc0: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 20 28 test-name). (
ecd0: 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f setenv "MT_TEST_
ece0: 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 NAME" test-name)
ecf0: 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 65 6e 76 ;; . (setenv
ed00: 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 20 20 "MT_ITEMPATH"
ed10: 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 20 20 28 item-path). (
ed20: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
ed30: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 ME" runname).
ed40: 20 20 20 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 (runs:set-meg
ed50: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 atest-env-vars r
ed60: 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 20 69 un-id area-dat i
ed70: 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e 61 6d nrunname: runnam
ed80: 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 e) ;; these may
ed90: 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 be needed by the
eda0: 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 launching proce
edb0: 73 73 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 ss. (change-d
edc0: 69 72 65 63 74 6f 72 79 20 74 6f 70 70 61 74 68 irectory toppath
edd0: 29 0a 0a 20 20 20 20 3b 3b 20 48 65 72 65 20 69 ).. ;; Here i
ede0: 73 20 77 68 65 72 65 20 74 68 65 20 74 65 73 74 s where the test
edf0: 5f 6d 65 74 61 20 74 61 62 6c 65 20 69 73 20 62 _meta table is b
ee00: 65 73 74 20 75 70 64 61 74 65 64 0a 20 20 20 20 est updated.
ee10: 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 ;; Yes, another
ee20: 75 73 65 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 use of a global
ee30: 66 6f 72 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 for caching. Nee
ee40: 64 20 61 20 62 65 74 74 65 72 20 77 61 79 3f 0a d a better way?.
ee50: 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 54 68 ;;. ;; Th
ee60: 65 72 65 20 69 73 20 6e 6f 77 20 61 20 73 69 6e ere is now a sin
ee70: 67 6c 65 20 63 61 6c 6c 20 74 6f 20 72 75 6e 73 gle call to runs
ee80: 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 :update-all-test
ee90: 5f 6d 65 74 61 20 61 6e 64 20 74 68 69 73 20 0a _meta and this .
eea0: 20 20 20 20 3b 3b 20 70 65 72 2d 74 65 73 74 20 ;; per-test
eeb0: 63 61 6c 6c 20 69 73 20 6e 6f 74 20 6e 65 65 64 call is not need
eec0: 65 64 2e 20 47 69 76 65 6e 20 74 68 65 20 64 65 ed. Given the de
eed0: 6c 69 63 61 63 79 20 6f 66 20 74 68 65 20 6d 6f licacy of the mo
eee0: 76 65 20 74 6f 20 0a 20 20 20 20 3b 3b 20 76 31 ve to . ;; v1
eef0: 2e 35 35 20 74 68 69 73 20 63 6f 64 65 20 69 73 .55 this code is
ef00: 20 62 65 69 6e 67 20 6c 65 66 74 20 69 6e 20 70 being left in p
ef10: 6c 61 63 65 20 66 6f 72 20 74 68 65 20 74 69 6d lace for the tim
ef20: 65 20 62 65 69 6e 67 2e 0a 20 20 20 20 3b 3b 0a e being.. ;;.
ef30: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
ef40: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
ef50: 61 75 6c 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d ault *test-meta-
ef60: 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 updated* test-na
ef70: 6d 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 me #f)).
ef80: 28 62 65 67 69 6e 0a 09 20 20 20 28 68 61 73 68 (begin.. (hash
ef90: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 -table-set! *tes
efa0: 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 t-meta-updated*
efb0: 74 65 73 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 test-name #t).
efc0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 75 (runs:u
efd0: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
efe0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
eff0: 6f 6e 66 20 61 72 65 61 2d 64 61 74 29 29 29 0a onf area-dat))).
f000: 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 74 65 6d . ;; item
f010: 64 61 74 20 3d 3e 20 28 28 72 69 70 65 6e 65 73 dat => ((ripenes
f020: 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 s "overripe") (t
f030: 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c emperature "cool
f040: 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d ") (season "summ
f050: 65 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 er")). (let*
f060: 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 ((new-test-path
f070: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
f080: 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 rse (cons test-p
f090: 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 ath (map cadr it
f0a0: 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 emdat)) "/"))..
f0b0: 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 (test-id
f0c0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
f0d0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
f0e0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 61 72 65 me item-path are
f0f0: 61 2d 64 61 74 29 29 0a 09 20 20 20 28 74 65 73 a-dat)).. (tes
f100: 74 64 61 74 20 20 20 20 20 20 20 28 69 66 20 74 tdat (if t
f110: 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d est-id (rmt:get-
f120: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
f130: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 61 run-id test-id a
f140: 72 65 61 2d 64 61 74 29 20 23 66 29 29 29 0a 20 rea-dat) #f))).
f150: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
f160: 73 74 64 61 74 29 0a 09 20 20 28 6c 65 74 20 6c stdat).. (let l
f170: 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b 20 65 oop ().. ;; e
f180: 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 70 nsure that the p
f190: 61 74 68 20 65 78 69 73 74 73 20 62 65 66 6f 72 ath exists befor
f1a0: 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 68 e registering th
f1b0: 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 4e e test.. ;; N
f1c0: 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f 6e OPE: Cannot! Don
f1d0: 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 63 't know yet whic
f1e0: 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c 6c h disk area will
f1f0: 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e 2e be assigned....
f200: 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 6d .. ;; (system
f210: 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d 70 (conc "mkdir -p
f220: 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 " new-test-path
f230: 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 )).. ;;..
f240: 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ;; (open-run-clo
f250: 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 65 se tests:registe
f260: 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 r-test db run-id
f270: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
f280: 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 20 path).. ;;..
f290: 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 74 ;; NB// for t
f2a0: 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 49 he above line. I
f2b0: 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 74 want the test t
f2c0: 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 64 20 o be registered
f2d0: 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 73 long before this
f2e0: 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 61 routine gets ca
f2f0: 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 20 lled!.. ;;..
f300: 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 (if (not test
f310: 2d 69 64 29 28 73 65 74 21 20 74 65 73 74 2d 69 -id)(set! test-i
f320: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
f330: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
f340: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 61 72 ame item-path ar
f350: 65 61 2d 64 61 74 29 29 29 0a 09 20 20 20 20 28 ea-dat))).. (
f360: 69 66 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 if (not test-id)
f370: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
f380: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 ebug:print 2 "WA
f390: 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 RN: Test not pre
f3a0: 2d 63 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e -created? test-n
f3b0: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
f3c0: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 ", item-path=" i
f3d0: 74 65 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d tem-path ", run-
f3e0: 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 id=" run-id)...
f3f0: 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
f400: 6c 6c 20 27 72 65 67 69 73 74 65 72 2d 74 65 73 ll 'register-tes
f410: 74 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 t run-id area-da
f420: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 t run-id test-na
f430: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 61 72 65 me item-path are
f440: 61 2d 64 61 74 29 0a 09 09 20 20 28 73 65 74 21 a-dat)... (set!
f450: 20 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 test-id (rmt:ge
f460: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
f470: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
f480: 70 61 74 68 20 61 72 65 61 2d 64 61 74 29 29 29 path area-dat)))
f490: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
f4a0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 int-info 4 "test
f4b0: 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c -id=" test-id ",
f4c0: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
f4d0: 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 ", test-name="
f4e0: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 test-name ", ite
f4f0: 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d m-path=\"" item-
f500: 70 61 74 68 20 22 5c 22 22 29 0a 09 20 20 20 20 path "\"")..
f510: 28 73 65 74 21 20 74 65 73 74 64 61 74 20 28 72 (set! testdat (r
f520: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
f530: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
f540: 73 74 2d 69 64 20 61 72 65 61 2d 64 61 74 29 29 st-id area-dat))
f550: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 .. (if (not t
f560: 65 73 74 64 61 74 29 0a 09 09 28 62 65 67 69 6e estdat)...(begin
f570: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
f580: 74 2d 69 6e 66 6f 20 30 20 22 57 41 52 4e 49 4e t-info 0 "WARNIN
f590: 47 3a 20 73 65 72 76 65 72 20 69 73 20 6f 76 65 G: server is ove
f5a0: 72 6c 6f 61 64 65 64 2c 20 74 72 79 69 6e 67 20 rloaded, trying
f5b0: 61 67 61 69 6e 20 69 6e 20 6f 6e 65 20 73 65 63 again in one sec
f5c0: 6f 6e 64 22 29 0a 09 09 20 20 28 74 68 72 65 61 ond")... (threa
f5d0: 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 20 20 d-sleep! 1)...
f5e0: 28 6c 6f 6f 70 29 29 29 29 29 0a 20 20 20 20 20 (loop))))).
f5f0: 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 61 (if (not testda
f600: 74 29 20 3b 3b 20 73 68 6f 75 6c 64 20 4e 4f 54 t) ;; should NOT
f610: 20 68 61 70 70 65 6e 0a 09 20 20 28 64 65 62 75 happen.. (debu
f620: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
f630: 3a 20 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 : failed to get
f640: 74 65 73 74 20 72 65 63 6f 72 64 20 66 6f 72 20 test record for
f650: 74 65 73 74 2d 69 64 20 22 20 74 65 73 74 2d 69 test-id " test-i
f660: 64 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 d)). (set!
f670: 74 65 73 74 2d 69 64 20 28 64 62 3a 74 65 73 74 test-id (db:test
f680: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
f690: 29 0a 20 20 20 20 20 20 28 69 66 20 28 66 69 6c ). (if (fil
f6a0: 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 70 e-exists? test-p
f6b0: 61 74 68 29 0a 09 20 20 28 63 68 61 6e 67 65 2d ath).. (change-
f6c0: 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 directory test-p
f6d0: 61 74 68 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 ath).. (begin..
f6e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f6f0: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 72 75 "ERROR: test ru
f700: 6e 20 70 61 74 68 20 6e 6f 74 20 63 72 65 61 74 n path not creat
f710: 65 64 20 62 65 66 6f 72 65 20 61 74 74 65 6d 70 ed before attemp
f720: 74 69 6e 67 20 74 6f 20 72 75 6e 20 74 68 65 20 ting to run the
f730: 74 65 73 74 2e 20 50 65 72 68 61 70 73 20 79 6f test. Perhaps yo
f740: 75 20 61 72 65 20 72 75 6e 6e 69 6e 67 20 2d 72 u are running -r
f750: 65 6d 6f 76 65 2d 72 75 6e 73 20 61 74 20 74 68 emove-runs at th
f760: 65 20 73 61 6d 65 20 74 69 6d 65 3f 22 29 0a 09 e same time?")..
f770: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
f780: 63 74 6f 72 79 20 74 6f 70 70 61 74 68 29 29 29 ctory toppath)))
f790: 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 69 66 . (case (if
f7a0: 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 3a force ;; (args:
f7b0: 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 get-arg "-force"
f7c0: 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 )...'NOT_STARTED
f7d0: 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 0a 09 ...(if testdat..
f7e0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 . (string->sy
f7f0: 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
f800: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 tate testdat))..
f810: 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d . 'failed-to-
f820: 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 69 6c insert))..((fail
f830: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 ed-to-insert)..
f840: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
f850: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
f860: 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f insert the reco
f870: 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 rd into the db")
f880: 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 )..((NOT_STARTED
f890: 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 4c 45 54 COMPLETED DELET
f8a0: 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 75 6e ED).. (let ((run
f8b0: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 28 63 flag #f)).. (c
f8c0: 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 ond.. ;; -for
f8d0: 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 ce, run no matte
f8e0: 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 6f 72 r what.. (for
f8f0: 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 ce (set! runflag
f900: 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f #t)).. ;; NO
f910: 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e 20 6e T_STARTED, run n
f920: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 o matter what..
f930: 20 20 20 28 28 6d 65 6d 62 65 72 20 28 74 65 73 ((member (tes
f940: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
f950: 64 61 74 29 20 27 28 22 44 45 4c 45 54 45 44 22 dat) '("DELETED"
f960: 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 29 "NOT_STARTED"))
f970: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
f980: 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d )).. ;; not -
f990: 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 rerun and PASS,
f9a0: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 WARN or CHECK, d
f9b0: 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 o no run.. ((
f9c0: 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 and (or (not rer
f9d0: 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 un)... keep
f9e0: 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 going)... ;; Re
f9f0: 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 quire to force r
fa00: 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 e-run for COMPLE
fa10: 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 TED or *anything
fa20: 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 * + PASS,WARN or
fa30: 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 CHECK... (or (
fa40: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
fa50: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
fa60: 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 '("PASS" "WARN"
fa70: 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 20 "CHECK" "SKIP"
fa80: 22 57 41 49 56 45 44 22 29 29 0a 09 09 20 20 20 "WAIVED"))...
fa90: 20 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 (member (test
faa0: 3a 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 74 :get-state test
fab0: 64 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 dat) '("COMPLETE
fac0: 44 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 64 D")))) .. (d
fad0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
fae0: 32 20 22 72 75 6e 6e 69 6e 67 20 74 65 73 74 20 2 "running test
faf0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
fb00: 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 70 item-path " supp
fb10: 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 20 ressed as it is
fb20: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
fb30: 65 20 74 65 73 74 64 61 74 29 20 22 20 61 6e 64 e testdat) " and
fb40: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
fb50: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 tus testdat))..
fb60: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
fb70: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
fb80: 72 79 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d ry full-test-nam
fb90: 65 20 27 44 4f 4e 4f 54 52 55 4e 29 20 3b 3b 20 e 'DONOTRUN) ;;
fba0: 43 4f 4d 50 4c 45 54 45 44 29 0a 09 20 20 20 20 COMPLETED)..
fbb0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
fbc0: 66 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 f)).. ;; -rer
fbd0: 75 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 un and status is
fbe0: 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 one of the spec
fbf0: 69 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 ifed, run it..
fc00: 20 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 ((and rerun...
fc10: 20 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c (let* ((rerunl
fc20: 73 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c st (string-spl
fc30: 69 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 it rerun ","))..
fc40: 09 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 .. (must-rerun (
fc50: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
fc60: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
fc70: 20 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 rerunlst)))...
fc80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
fc90: 69 6e 66 6f 20 33 20 22 2d 72 65 72 75 6e 20 6c info 3 "-rerun l
fca0: 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 ist: " rerun ",
fcb0: 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 test-status: " (
fcc0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
fcd0: 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d testdat)", must-
fce0: 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 rerun: " must-re
fcf0: 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d run)... must-
fd00: 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 rerun)).. (d
fd10: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
fd20: 32 20 22 52 65 72 75 6e 20 66 6f 72 63 65 64 20 2 "Rerun forced
fd30: 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d for test " test-
fd40: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
fd50: 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 th).. (set!
fd60: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
fd70: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c ;; -keepgoing,
fd80: 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 do not rerun FA
fd90: 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b 65 IL.. ((and ke
fda0: 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d epgoing... (mem
fdb0: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
fdc0: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 atus testdat) '(
fdd0: 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 20 "FAIL")))..
fde0: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
fdf0: 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6e )).. ((and (n
fe00: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 6d ot rerun)... (m
fe10: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
fe20: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
fe30: 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 '("FAIL" "n/a"))
fe40: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
fe50: 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 nflag #t))..
fe60: 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e 66 (else (set! runf
fe70: 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 64 lag #f))).. (d
fe80: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 52 55 ebug:print 4 "RU
fe90: 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 NNING => runflag
fea0: 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 54 : " runflag " ST
feb0: 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 74 ATE: " (test:get
fec0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 -state testdat)
fed0: 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 73 " STATUS: " (tes
fee0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
fef0: 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 28 tdat)).. (if (
ff00: 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 not runflag)..
ff10: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 61 (if (not pa
ff20: 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 20 rent-test)...
ff30: 28 69 66 20 28 72 75 6e 73 3a 6c 6f 77 6e 6f 69 (if (runs:lownoi
ff40: 73 65 20 28 63 6f 6e 63 20 22 6e 6f 74 20 73 74 se (conc "not st
ff50: 61 72 74 69 6e 67 20 74 65 73 74 22 20 66 75 6c arting test" ful
ff60: 6c 2d 74 65 73 74 2d 6e 61 6d 65 29 20 36 30 29 l-test-name) 60)
ff70: 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
ff80: 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 :print 1 "NOTE:
ff90: 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 73 Not starting tes
ffa0: 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 t " full-test-na
ffb0: 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 74 me " as it is st
ffc0: 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 65 ate \"" (test:ge
ffd0: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
ffe0: 20 0a 09 09 09 09 20 20 20 20 22 5c 22 20 61 6e ..... "\" an
fff0: 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 d status \"" (te
10000 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
10010 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 stdat) "\", use
10020 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 73 74 -rerun \"" (test
10030 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
10040 64 61 74 29 0a 09 09 09 09 20 20 20 20 22 5c 22 dat)..... "\"
10050 20 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 or -force to ov
10060 65 72 72 69 64 65 22 29 29 29 0a 09 20 20 20 20 erride")))..
10070 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c ;; NOTE: No l
10080 6f 6e 67 65 72 20 62 65 20 63 68 65 63 6b 69 6e onger be checkin
10090 67 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 g prerequisites
100a0 68 65 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 here! Will never
100b0 20 67 65 74 20 68 65 72 65 20 75 6e 6c 65 73 73 get here unless
100c0 20 70 72 65 72 65 71 73 20 61 72 65 0a 09 20 20 prereqs are..
100d0 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 61 6c ;; al
100e0 72 65 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 ready met...
100f0 20 20 20 3b 3b 20 54 68 69 73 20 77 6f 75 6c 64 ;; This would
10100 20 62 65 20 61 20 67 72 65 61 74 20 70 6c 61 63 be a great plac
10110 65 20 74 6f 20 64 6f 20 74 68 65 20 70 72 6f 63 e to do the proc
10120 65 73 73 2d 66 6f 72 6b 0a 09 20 20 20 20 20 20 ess-fork..
10130 20 3b 3b 20 0a 09 20 20 20 20 20 20 20 28 6c 65 ;; .. (le
10140 74 20 28 28 73 6b 69 70 2d 74 65 73 74 20 20 20 t ((skip-test
10150 23 66 29 0a 09 09 20 20 20 20 20 28 73 6b 69 70 #f)... (skip
10160 2d 63 68 65 63 6b 20 20 28 63 6f 6e 66 69 67 66 -check (configf
10170 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 65 73 :get-section tes
10180 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 29 29 29 t-conf "skip")))
10190 0a 09 09 20 28 63 6f 6e 64 20 0a 09 09 20 20 3b ... (cond ... ;
101a0 3b 20 48 61 76 65 20 74 6f 20 63 68 65 63 6b 20 ; Have to check
101b0 66 6f 72 20 73 6b 69 70 20 63 6f 6e 64 69 74 69 for skip conditi
101c0 6f 6e 73 2e 20 54 68 69 73 20 6f 6e 65 20 73 6b ons. This one sk
101d0 69 70 73 20 69 66 20 74 68 65 72 65 20 61 72 65 ips if there are
101e0 20 73 61 6d 65 2d 6e 61 6d 65 64 20 74 65 73 74 same-named test
101f0 73 0a 09 09 20 20 3b 3b 20 63 75 72 72 65 6e 74 s... ;; current
10200 6c 79 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 28 ly running... (
10210 28 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b 0a (and skip-check.
10220 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b ...(configf:look
10230 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 6b up test-conf "sk
10240 69 70 22 20 22 70 72 65 76 72 75 6e 6e 69 6e 67 ip" "prevrunning
10250 22 29 29 0a 09 09 20 20 20 3b 3b 20 72 75 6e 2d "))... ;; run-
10260 69 64 73 20 3d 20 23 66 20 6d 65 61 6e 73 20 2a ids = #f means *
10270 61 6c 6c 2a 20 72 75 6e 73 0a 09 09 20 20 20 28 all* runs... (
10280 6c 65 74 20 28 28 72 75 6e 6e 69 6e 67 2d 74 65 let ((running-te
10290 73 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 sts (rmt:get-tes
102a0 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 ts-for-runs-mind
102b0 61 74 61 20 23 66 20 66 75 6c 6c 2d 74 65 73 74 ata #f full-test
102c0 2d 6e 61 6d 65 20 27 28 22 52 55 4e 4e 49 4e 47 -name '("RUNNING
102d0 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 " "REMOTEHOSTSTA
102e0 52 54 22 20 22 4c 41 55 4e 43 48 45 44 22 29 20 RT" "LAUNCHED")
102f0 27 28 29 20 23 66 20 61 72 65 61 2d 64 61 74 29 '() #f area-dat)
10300 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 6e ))... (if (n
10310 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 6e 6e 69 6e ot (null? runnin
10320 67 2d 74 65 73 74 73 29 29 20 3b 3b 20 68 61 76 g-tests)) ;; hav
10330 65 20 74 6f 20 73 6b 69 70 20 0a 09 09 09 20 28 e to skip .... (
10340 73 65 74 21 20 73 6b 69 70 2d 74 65 73 74 20 22 set! skip-test "
10350 53 6b 69 70 70 69 6e 67 20 64 75 65 20 74 6f 20 Skipping due to
10360 70 72 65 76 69 6f 75 73 20 74 65 73 74 73 20 72 previous tests r
10370 75 6e 6e 69 6e 67 22 29 29 29 29 0a 09 09 20 20 unning"))))...
10380 28 28 61 6e 64 20 73 6b 69 70 2d 63 68 65 63 6b ((and skip-check
10390 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ....(configf:loo
103a0 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 kup test-conf "s
103b0 6b 69 70 22 20 22 66 69 6c 65 65 78 69 73 74 73 kip" "fileexists
103c0 22 29 29 0a 09 09 20 20 20 28 69 66 20 28 66 69 "))... (if (fi
103d0 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 66 le-exists? (conf
103e0 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d igf:lookup test-
103f0 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 66 69 6c conf "skip" "fil
10400 65 65 78 69 73 74 73 22 29 29 0a 09 09 20 20 20 eexists"))...
10410 20 20 20 20 28 73 65 74 21 20 73 6b 69 70 2d 74 (set! skip-t
10420 65 73 74 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 est (conc "Skipp
10430 69 6e 67 20 64 75 65 20 74 6f 20 65 78 69 73 74 ing due to exist
10440 61 6e 63 65 20 6f 66 20 66 69 6c 65 20 22 20 28 ance of file " (
10450 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 configf:lookup t
10460 65 73 74 2d 63 6f 6e 66 20 22 73 6b 69 70 22 20 est-conf "skip"
10470 22 66 69 6c 65 65 78 69 73 74 73 22 29 29 29 29 "fileexists"))))
10480 29 0a 0a 09 09 20 20 28 28 61 6e 64 20 73 6b 69 ).... ((and ski
10490 70 2d 63 68 65 63 6b 0a 09 09 09 28 63 6f 6e 66 p-check....(conf
104a0 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d igf:lookup test-
104b0 63 6f 6e 66 20 22 73 6b 69 70 22 20 22 72 75 6e conf "skip" "run
104c0 64 65 6c 61 79 22 29 29 0a 09 09 20 20 20 3b 3b delay"))... ;;
104d0 20 72 75 6e 2d 69 64 73 20 3d 20 23 66 20 6d 65 run-ids = #f me
104e0 61 6e 73 20 2a 61 6c 6c 2a 20 72 75 6e 73 0a 09 ans *all* runs..
104f0 09 20 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 73 . (let* ((nums
10500 65 63 6f 6e 64 73 20 20 20 20 20 20 28 63 6f 6d econds (com
10510 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 2d 3e mon:hms-string->
10520 73 65 63 6f 6e 64 73 20 28 63 6f 6e 66 69 67 66 seconds (configf
10530 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e :lookup test-con
10540 66 20 22 73 6b 69 70 22 20 22 72 75 6e 64 65 6c f "skip" "rundel
10550 61 79 22 29 29 29 0a 09 09 09 20 20 28 72 75 6e ay"))).... (run
10560 6e 69 6e 67 2d 74 65 73 74 73 20 20 20 28 72 6d ning-tests (rm
10570 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
10580 72 75 6e 73 2d 6d 69 6e 64 61 74 61 20 23 66 20 runs-mindata #f
10590 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 27 full-test-name '
105a0 28 22 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f ("RUNNING" "REMO
105b0 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 TEHOSTSTART" "LA
105c0 55 4e 43 48 45 44 22 29 20 27 28 29 20 23 66 29 UNCHED") '() #f)
105d0 29 0a 09 09 09 20 20 28 63 6f 6d 70 6c 65 74 65 ).... (complete
105e0 64 2d 74 65 73 74 73 20 28 72 6d 74 3a 67 65 74 d-tests (rmt:get
105f0 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d -tests-for-runs-
10600 6d 69 6e 64 61 74 61 20 23 66 20 66 75 6c 6c 2d mindata #f full-
10610 74 65 73 74 2d 6e 61 6d 65 20 27 28 22 43 4f 4d test-name '("COM
10620 50 4c 45 54 45 44 22 29 20 27 28 22 50 41 53 53 PLETED") '("PASS
10630 22 20 22 46 41 49 4c 22 20 22 41 42 4f 52 54 22 " "FAIL" "ABORT"
10640 29 20 23 66 29 29 0a 09 09 09 20 20 28 6c 61 73 ) #f)).... (las
10650 74 2d 72 75 6e 2d 74 69 6d 65 73 20 20 28 6d 61 t-run-times (ma
10660 70 20 64 62 3a 6d 69 6e 74 65 73 74 2d 67 65 74 p db:mintest-get
10670 2d 65 76 65 6e 74 5f 74 69 6d 65 20 63 6f 6d 70 -event_time comp
10680 6c 65 74 65 64 2d 74 65 73 74 73 29 29 0a 09 09 leted-tests))...
10690 09 20 20 28 74 69 6d 65 2d 73 69 6e 63 65 2d 6c . (time-since-l
106a0 61 73 74 20 28 2d 20 28 63 75 72 72 65 6e 74 2d ast (- (current-
106b0 73 65 63 6f 6e 64 73 29 20 28 61 70 70 6c 79 20 seconds) (apply
106c0 6d 61 78 20 6c 61 73 74 2d 72 75 6e 2d 74 69 6d max last-run-tim
106d0 65 73 29 29 29 29 0a 09 09 20 20 20 20 20 28 69 es))))... (i
106e0 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c f (or (not (null
106f0 3f 20 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 29 ? running-tests)
10700 29 20 3b 3b 20 68 61 76 65 20 74 6f 20 73 6b 69 ) ;; have to ski
10710 70 20 69 66 20 74 65 73 74 20 69 73 20 72 75 6e p if test is run
10720 6e 69 6e 67 0a 09 09 09 20 20 20 20 20 28 3e 20 ning.... (>
10730 6e 75 6d 73 65 63 6f 6e 64 73 20 74 69 6d 65 2d numseconds time-
10740 73 69 6e 63 65 2d 6c 61 73 74 29 29 0a 09 09 09 since-last))....
10750 20 28 73 65 74 21 20 73 6b 69 70 2d 74 65 73 74 (set! skip-test
10760 20 28 63 6f 6e 63 20 22 53 6b 69 70 70 69 6e 67 (conc "Skipping
10770 20 64 75 65 20 74 6f 20 70 72 65 76 69 6f 75 73 due to previous
10780 20 74 65 73 74 20 72 75 6e 20 6c 65 73 73 20 74 test run less t
10790 68 61 6e 20 22 20 28 63 6f 6e 66 69 67 66 3a 6c han " (configf:l
107a0 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
107b0 22 73 6b 69 70 22 20 22 72 75 6e 64 65 6c 61 79 "skip" "rundelay
107c0 22 29 20 22 20 61 67 6f 22 29 29 29 29 29 29 0a ") " ago")))))).
107d0 09 09 20 0a 09 09 20 28 69 66 20 73 6b 69 70 2d .. ... (if skip-
107e0 74 65 73 74 0a 09 09 20 20 20 20 20 28 62 65 67 test... (beg
107f0 69 6e 0a 09 09 20 20 20 20 20 20 20 28 6d 74 3a in... (mt:
10800 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
10810 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d tatus-by-id run-
10820 69 64 20 74 65 73 74 2d 69 64 20 22 43 4f 4d 50 id test-id "COMP
10830 4c 45 54 45 44 22 20 22 53 4b 49 50 22 20 73 6b LETED" "SKIP" sk
10840 69 70 2d 74 65 73 74 29 0a 09 09 20 20 20 20 20 ip-test)...
10850 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
10860 6e 66 6f 20 31 20 22 53 4b 49 50 50 49 4e 47 20 nfo 1 "SKIPPING
10870 54 65 73 74 20 22 20 66 75 6c 6c 2d 74 65 73 74 Test " full-test
10880 2d 6e 61 6d 65 20 22 20 64 75 65 20 74 6f 20 22 -name " due to "
10890 20 73 6b 69 70 2d 74 65 73 74 29 29 0a 09 09 20 skip-test))...
108a0 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 (if (not (la
108b0 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 2d 69 unch-test test-i
108c0 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 d run-id run-inf
108d0 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d o keyvals runnam
108e0 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 73 74 e test-conf test
108f0 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 -name test-path
10900 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 29 0a itemdat flags)).
10910 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 20 ... (begin....
10920 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
10930 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
10940 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 the test. Exiti
10950 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f ng as soon as po
10960 73 73 69 62 6c 65 22 29 0a 09 09 09 20 20 20 28 ssible").... (
10970 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 set! *globalexit
10980 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 status* 1) ;; ..
10990 09 09 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 .. (process-si
109a0 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 gnal (current-pr
109b0 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c ocess-id) signal
109c0 2f 6b 69 6c 6c 29 29 29 29 29 29 29 29 0a 09 28 /kill))))))))..(
109d0 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 (KILLED) .. (deb
109e0 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
109f0 3a 20 22 20 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 : " full-test-na
10a00 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 me " is already
10a10 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 running or was e
10a20 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c xplictly killed,
10a30 20 75 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c use -force to l
10a40 61 75 6e 63 68 20 69 74 2e 22 29 0a 09 20 28 68 aunch it.").. (h
10a50 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
10a60 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 64 62 est-registry (db
10a70 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
10a80 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 name test-name t
10a90 65 73 74 2d 70 61 74 68 29 20 27 44 4f 4e 4f 54 est-path) 'DONOT
10aa0 52 55 4e 29 29 20 3b 3b 20 4b 49 4c 4c 45 44 29 RUN)) ;; KILLED)
10ab0 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 )..((LAUNCHED RE
10ac0 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 MOTEHOSTSTART RU
10ad0 4e 4e 49 4e 47 29 20 20 0a 09 20 28 64 65 62 75 NNING) .. (debu
10ae0 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a g:print 2 "NOTE:
10af0 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 " test-name " i
10b00 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e s already runnin
10b10 67 22 29 29 0a 09 3b 3b 20 28 69 66 20 28 3e 20 g"))..;; (if (>
10b20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
10b30 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d nds)(+ (db:test-
10b40 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 get-event_time t
10b50 65 73 74 64 61 74 29 0a 09 3b 3b 20 09 09 09 20 estdat)..;; ...
10b60 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
10b70 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 et-run_duration
10b80 74 65 73 74 64 61 74 29 29 29 0a 09 3b 3b 20 09 testdat)))..;; .
10b90 28 6f 72 20 69 6e 63 6f 6d 70 6c 65 74 65 2d 74 (or incomplete-t
10ba0 69 6d 65 6f 75 74 0a 09 3b 3b 20 09 20 20 20 20 imeout..;; .
10bb0 36 30 30 30 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6000)) ;; i.e. n
10bc0 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 o update for mor
10bd0 65 20 74 68 61 6e 20 36 30 30 30 20 73 65 63 6f e than 6000 seco
10be0 6e 64 73 0a 09 3b 3b 20 20 20 20 20 20 28 62 65 nds..;; (be
10bf0 67 69 6e 0a 09 3b 3b 20 20 20 20 20 20 20 20 28 gin..;; (
10c00 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
10c10 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 ARNING: Test " t
10c20 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 est-name " appea
10c30 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 rs to be dead. F
10c40 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 orcing it to sta
10c50 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e te INCOMPLETE an
10c60 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 d status STUCK/D
10c70 45 41 44 22 29 0a 09 3b 3b 20 20 20 20 20 20 20 EAD")..;;
10c80 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
10c90 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 -status! run-id
10ca0 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c test-id "INCOMPL
10cb0 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 ETE" "STUCK/DEAD
10cc0 22 20 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 " "" #f))..;;
10cd0 20 20 20 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 ;; (tests:t
10ce0 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
10cf0 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c test-id "INCOMPL
10d00 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 ETE" "STUCK/DEAD
10d10 22 20 22 22 20 23 66 29 29 0a 09 3b 3b 20 20 20 " "" #f))..;;
10d20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
10d30 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 2 "NOTE: " test-
10d40 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 name " is alread
10d50 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 y running")))..(
10d60 65 6c 73 65 20 20 20 20 20 20 0a 09 20 28 64 65 else .. (de
10d70 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
10d80 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 OR: Failed to la
10d90 75 6e 63 68 20 74 65 73 74 20 22 20 66 75 6c 6c unch test " full
10da0 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e -test-name ". Un
10db0 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 recognised state
10dc0 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
10dd0 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 te testdat)).. (
10de0 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
10df0 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
10e00 74 61 74 65 20 74 65 73 74 64 61 74 29 29 20 0a tate testdat)) .
10e10 09 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 20 . ((COMPLETED
10e20 49 4e 43 4f 4d 50 4c 45 54 45 29 0a 09 20 20 20 INCOMPLETE)..
10e30 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
10e40 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
10e50 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
10e60 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
10e70 65 20 74 65 73 74 2d 70 61 74 68 29 20 27 44 4f e test-path) 'DO
10e80 4e 4f 54 52 55 4e 29 29 0a 09 20 20 20 28 65 6c NOTRUN)).. (el
10e90 73 65 0a 09 20 20 20 20 28 68 61 73 68 2d 74 61 se.. (hash-ta
10ea0 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
10eb0 67 69 73 74 72 79 20 28 64 62 3a 74 65 73 74 2d gistry (db:test-
10ec0 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 make-full-name t
10ed0 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 est-name test-pa
10ee0 74 68 29 20 27 44 4f 4e 4f 54 52 55 4e 29 29 29 th) 'DONOTRUN)))
10ef0 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
10f00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
10f40 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 ;; END OF NEW ST
10f50 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d UFF.;;==========
10f60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10f90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
10fa0 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 efine (get-dir-u
10fb0 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 p-n dir . params
10fc0 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 ) . (let ((dpar
10fd0 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ts (string-spli
10fe0 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f t dir "/"))..(co
10ff0 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f unt (if (null?
11000 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 params) 1 (car
11010 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 params)))). (
11020 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 conc "/" (string
11030 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 -intersperse ..
11040 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 (take dpar
11050 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 ts (- (length dp
11060 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 arts) count))..
11070 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a 0a 28 "/"))))..(
11080 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 63 define (runs:rec
11090 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d 77 69 ursive-delete-wi
110a0 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 72 65 61 th-error-msg rea
110b0 6c 2d 64 69 72 29 0a 20 20 28 69 66 20 28 3e 20 l-dir). (if (>
110c0 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
110d0 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 72 m -rf " real-dir
110e0 29 29 20 30 29 0a 20 20 20 20 20 20 28 62 65 67 )) 0). (beg
110f0 69 6e 0a 09 3b 3b 20 46 41 49 4c 45 44 2c 20 70 in..;; FAILED, p
11100 6f 73 73 69 62 6c 79 20 64 75 65 20 74 6f 20 70 ossibly due to p
11110 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 6f 20 63 ermissions, do c
11120 68 6d 6f 64 20 61 2b 72 77 78 20 74 68 65 6e 20 hmod a+rwx then
11130 74 72 79 20 6f 6e 65 20 6d 6f 72 65 20 74 69 6d try one more tim
11140 65 0a 09 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 e..(system (conc
11150 20 22 63 68 6d 6f 64 20 2d 52 20 61 2b 72 77 78 "chmod -R a+rwx
11160 20 22 20 72 65 61 6c 2d 64 69 72 29 29 0a 09 28 " real-dir))..(
11170 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 63 if (> (system (c
11180 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 65 onc "rm -rf " re
11190 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 20 20 20 al-dir)) 0)..
111a0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
111b0 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 61 "ERROR: There wa
111c0 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f s a problem remo
111d0 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 20 ving " real-dir
111e0 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 29 " with rm -f")))
111f0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
11200 73 3a 73 61 66 65 2d 64 65 6c 65 74 65 2d 74 65 s:safe-delete-te
11210 73 74 2d 64 69 72 20 72 65 61 6c 2d 64 69 72 29 st-dir real-dir)
11220 0a 20 20 3b 3b 20 66 69 72 73 74 20 64 65 6c 65 . ;; first dele
11230 74 65 20 61 6c 6c 20 73 75 62 2d 64 69 72 65 63 te all sub-direc
11240 74 6f 72 69 65 73 0a 20 20 28 64 69 72 65 63 74 tories. (direct
11250 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 28 6c 61 ory-fold . (la
11260 6d 62 64 61 20 28 66 20 78 29 0a 20 20 20 20 20 mbda (f x).
11270 28 6c 65 74 20 28 28 66 75 6c 6c 6e 61 6d 65 20 (let ((fullname
11280 28 63 6f 6e 63 20 72 65 61 6c 2d 64 69 72 20 22 (conc real-dir "
11290 2f 22 20 66 29 29 29 0a 20 20 20 20 20 20 20 28 /" f))). (
112a0 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 66 if (directory? f
112b0 75 6c 6c 6e 61 6d 65 29 28 72 75 6e 73 3a 72 65 ullname)(runs:re
112c0 63 75 72 73 69 76 65 2d 64 65 6c 65 74 65 2d 77 cursive-delete-w
112d0 69 74 68 2d 65 72 72 6f 72 2d 6d 73 67 20 66 75 ith-error-msg fu
112e0 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 28 llname))). (
112f0 2b 20 31 20 78 29 29 0a 20 20 20 30 20 72 65 61 + 1 x)). 0 rea
11300 6c 2d 64 69 72 29 0a 20 20 3b 3b 20 74 68 65 6e l-dir). ;; then
11310 20 66 69 6c 65 73 20 6f 74 68 65 72 20 74 68 61 files other tha
11320 6e 20 2a 74 65 73 74 64 61 74 2e 64 62 2a 0a 20 n *testdat.db*.
11330 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 (directory-fold
11340 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 20 . (lambda (f
11350 78 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 66 x). (let ((f
11360 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 72 65 ullname (conc re
11370 61 6c 2d 64 69 72 20 22 2f 22 20 66 29 29 29 0a al-dir "/" f))).
11380 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
11390 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 28 (string-search (
113a0 72 65 67 65 78 70 20 22 74 65 73 74 64 61 74 2e regexp "testdat.
113b0 64 62 22 29 20 66 29 29 0a 09 20 20 20 28 72 75 db") f)).. (ru
113c0 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 65 6c ns:recursive-del
113d0 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d ete-with-error-m
113e0 73 67 20 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 sg fullname))).
113f0 20 20 20 20 28 2b 20 31 20 78 29 29 0a 20 20 20 (+ 1 x)).
11400 30 20 72 65 61 6c 2d 64 69 72 29 0a 20 20 3b 3b 0 real-dir). ;;
11410 20 74 68 65 6e 20 74 68 65 20 65 6e 74 69 72 65 then the entire
11420 20 64 69 72 65 63 74 6f 72 79 0a 20 20 28 72 75 directory. (ru
11430 6e 73 3a 72 65 63 75 72 73 69 76 65 2d 64 65 6c ns:recursive-del
11440 65 74 65 2d 77 69 74 68 2d 65 72 72 6f 72 2d 6d ete-with-error-m
11450 73 67 20 72 65 61 6c 2d 64 69 72 29 29 0a 0a 3b sg real-dir))..;
11460 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b ; Remove runs.;;
11470 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 73 fields are pass
11480 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 0a ing in through .
11490 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 ;; action:.;;
114a0 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 'remove-runs.;;
114b0 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d 73 'set-state-s
114c0 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f tatus.;;.;; NB//
114d0 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e 20 should pass in
114e0 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 keys?.;;.(define
114f0 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f (runs:operate-o
11500 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 74 20 n action target
11510 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 74 runnamepatt test
11520 70 61 74 74 20 61 72 65 61 2d 64 61 74 20 23 21 patt area-dat #!
11530 6b 65 79 20 28 73 74 61 74 65 20 23 66 29 28 73 key (state #f)(s
11540 74 61 74 75 73 20 23 66 29 28 6e 65 77 2d 73 74 tatus #f)(new-st
11550 61 74 65 2d 73 74 61 74 75 73 20 23 66 29 28 6d ate-status #f)(m
11560 6f 64 65 20 27 72 65 6d 6f 76 65 2d 61 6c 6c 29 ode 'remove-all)
11570 28 6f 70 74 69 6f 6e 73 20 27 28 29 29 29 0a 20 (options '())).
11580 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 (common:clear-c
11590 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 aches) ;; clear
115a0 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 all caches. (le
115b0 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
115c0 20 20 23 66 29 0a 09 20 28 74 64 62 64 61 74 20 #f).. (tdbdat
115d0 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 (tasks:ope
115e0 6e 2d 64 62 20 61 72 65 61 2d 64 61 74 29 29 0a n-db area-dat)).
115f0 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 . (keys
11600 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 20 61 72 (rmt:get-keys ar
11610 65 61 2d 64 61 74 29 29 0a 09 20 28 72 75 6e 64 ea-dat)).. (rund
11620 61 74 20 20 20 20 20 20 20 28 6d 74 3a 67 65 74 at (mt:get
11630 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 -runs-by-patt ke
11640 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
11650 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 arget)).. (heade
11660 72 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d r (vector-
11670 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
11680 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 20 28 (runs (
11690 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
116a0 74 20 31 29 29 0a 09 20 28 73 74 61 74 65 73 20 t 1)).. (states
116b0 20 20 20 20 20 20 28 69 66 20 73 74 61 74 65 20 (if state
116c0 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 (string-split s
116d0 74 61 74 65 20 20 22 2c 22 29 20 27 28 29 29 29 tate ",") '()))
116e0 0a 09 20 28 73 74 61 74 75 73 65 73 20 20 20 20 .. (statuses
116f0 20 28 69 66 20 73 74 61 74 75 73 20 28 73 74 72 (if status (str
11700 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 75 73 ing-split status
11710 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 ",") '())).. (s
11720 74 61 74 65 2d 73 74 61 74 75 73 20 28 69 66 20 tate-status (if
11730 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 61 (string? new-sta
11740 74 65 2d 73 74 61 74 75 73 29 20 28 73 74 72 69 te-status) (stri
11750 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 61 ng-split new-sta
11760 74 65 2d 73 74 61 74 75 73 20 22 2c 22 29 20 27 te-status ",") '
11770 28 23 66 20 23 66 29 29 29 29 0a 20 20 20 20 28 (#f #f)))). (
11780 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
11790 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 4 "runs:operate
117a0 2d 6f 6e 20 3d 3e 20 48 65 61 64 65 72 3a 20 22 -on => Header: "
117b0 20 68 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e header " action
117c0 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 : " action " new
117d0 2d 73 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 -state-status: "
117e0 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 new-state-statu
117f0 73 29 0a 20 20 20 20 28 69 66 20 28 3e 20 32 20 s). (if (> 2
11800 28 6c 65 6e 67 74 68 20 73 74 61 74 65 2d 73 74 (length state-st
11810 61 74 75 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 atus))..(begin..
11820 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
11830 20 22 45 52 52 4f 52 3a 20 74 68 65 20 70 61 72 "ERROR: the par
11840 61 6d 65 74 65 72 20 74 6f 20 2d 73 65 74 2d 73 ameter to -set-s
11850 74 61 74 65 2d 73 74 61 74 75 73 20 69 73 20 61 tate-status is a
11860 20 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 65 64 comma delimited
11870 20 73 74 72 69 6e 67 2e 20 45 2e 67 2e 20 43 4f string. E.g. CO
11880 4d 50 4c 45 54 45 44 2c 46 41 49 4c 22 29 0a 09 MPLETED,FAIL")..
11890 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 (exit))). (
118a0 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
118b0 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 ambda (run).
118c0 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 79 (let ((runkey
118d0 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
118e0 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 erse (map (lambd
118f0 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 62 3a a (k).......(db:
11900 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
11910 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 6b der run header k
11920 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 )) keys) "/"))..
11930 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 (dirs-to-re
11940 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d move (make-hash-
11950 74 61 62 6c 65 29 29 0a 09 20 20 20 20 20 28 70 table)).. (p
11960 72 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 28 6c roc-get-tests (l
11970 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 ambda (run-id)..
11980 09 09 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d .. (mt:get-
11990 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 tests-for-run ru
119a0 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 20 20 74 n-id....... t
119b0 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
119c0 74 61 74 75 73 65 73 20 61 72 65 61 2d 64 61 74 tatuses area-dat
119d0 0a 09 09 09 09 09 09 20 20 20 20 6e 6f 74 2d 69 ....... not-i
119e0 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 n: #f.......
119f0 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 sort-by: (case
11a00 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 20 20 action........
11a10 20 20 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 ((remove-ru
11a20 6e 73 29 20 27 72 75 6e 64 69 72 29 0a 09 09 09 ns) 'rundir)....
11a30 09 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 .... (else
11a40 20 20 20 20 20 20 20 20 20 20 27 65 76 65 6e 74 'event
11a50 5f 74 69 6d 65 29 29 29 29 29 29 0a 09 20 28 6c _time)))))).. (l
11a60 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 et* ((run-id
11a70 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
11a80 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
11a90 65 72 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e er "id"))...(run
11aa0 2d 73 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 -state (db:get-v
11ab0 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
11ac0 75 6e 20 68 65 61 64 65 72 20 22 73 74 61 74 65 un header "state
11ad0 22 29 29 0a 09 09 28 72 75 6e 2d 6e 61 6d 65 20 "))...(run-name
11ae0 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
11af0 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
11b00 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a der "runname")).
11b10 09 09 28 74 65 73 74 73 20 20 20 20 20 28 69 66 ..(tests (if
11b20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 72 75 (not (equal? ru
11b30 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 64 22 n-state "locked"
11b40 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 70 72 )).... (pr
11b50 6f 63 2d 67 65 74 2d 74 65 73 74 73 20 72 75 6e oc-get-tests run
11b60 2d 69 64 29 0a 09 09 09 20 20 20 20 20 20 20 27 -id).... '
11b70 28 29 29 29 0a 09 09 28 6c 61 73 74 74 70 61 74 ()))...(lasttpat
11b80 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 h "/does/not/exi
11b90 73 74 2f 49 2f 68 6f 70 65 22 29 0a 09 09 28 77 st/I/hope")...(w
11ba0 6f 72 6b 65 72 2d 74 68 72 65 61 64 20 23 66 29 orker-thread #f)
11bb0 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
11bc0 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
11bd0 6f 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 operate-on run="
11be0 20 72 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 run ", header="
11bf0 20 68 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 header).. (if
11c00 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
11c10 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 ts)).. (be
11c20 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 gin... (case act
11c30 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 ion... ((remov
11c40 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 28 69 e-runs)... (i
11c50 66 20 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 f (tasks:need-se
11c60 72 76 65 72 20 72 75 6e 2d 69 64 20 61 72 65 61 rver run-id area
11c70 2d 64 61 74 29 28 74 61 73 6b 73 3a 73 74 61 72 -dat)(tasks:star
11c80 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d 73 t-and-wait-for-s
11c90 65 72 76 65 72 20 74 64 62 64 61 74 20 72 75 6e erver tdbdat run
11ca0 2d 69 64 20 31 30 29 29 0a 09 09 20 20 20 20 3b -id 10))... ;
11cb0 3b 20 73 65 65 6b 20 61 6e 64 20 6b 69 6c 6c 20 ; seek and kill
11cc0 69 6e 20 66 6c 69 67 68 74 20 2d 72 75 6e 74 65 in flight -runte
11cd0 73 74 73 20 77 69 74 68 20 25 20 61 73 20 74 65 sts with % as te
11ce0 73 74 70 61 74 74 20 68 65 72 65 0a 09 09 20 20 stpatt here...
11cf0 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 65 (if (equal? te
11d00 73 74 70 61 74 74 20 22 25 22 29 0a 09 09 09 28 stpatt "%")....(
11d10 74 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 tasks:kill-runne
11d20 72 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d r target run-nam
11d30 65 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 e)....(debug:pri
11d40 6e 74 20 30 20 22 6e 6f 74 20 61 74 74 65 6d 70 nt 0 "not attemp
11d50 74 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 61 6e 79 ting to kill any
11d60 20 72 75 6e 20 6c 61 75 6e 63 68 65 72 20 70 72 run launcher pr
11d70 6f 63 65 73 73 65 73 20 61 73 20 74 65 73 74 70 ocesses as testp
11d80 61 74 74 20 69 73 20 22 20 74 65 73 74 70 61 74 att is " testpat
11d90 74 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 t))... (debug
11da0 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
11db0 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e ng tests for run
11dc0 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
11dd0 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
11de0 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
11df0 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 r "runname")))..
11e00 09 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d . ((set-state-
11e10 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 69 status)... (i
11e20 66 20 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 f (tasks:need-se
11e30 72 76 65 72 20 72 75 6e 2d 69 64 20 61 72 65 61 rver run-id area
11e40 2d 64 61 74 29 28 74 61 73 6b 73 3a 73 74 61 72 -dat)(tasks:star
11e50 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d 73 t-and-wait-for-s
11e60 65 72 76 65 72 20 74 64 62 64 61 74 20 72 75 6e erver tdbdat run
11e70 2d 69 64 20 31 30 29 29 0a 09 09 20 20 20 20 28 -id 10))... (
11e80 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4d debug:print 1 "M
11e90 6f 64 69 66 79 69 6e 67 20 73 74 61 74 65 20 61 odifying state a
11ea0 6e 64 20 73 74 61 75 73 20 66 6f 72 20 74 65 73 nd staus for tes
11eb0 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 ts for run: " ru
11ec0 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
11ed0 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
11ee0 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
11ef0 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 name")))... ((
11f00 70 72 69 6e 74 2d 72 75 6e 29 0a 09 09 20 20 20 print-run)...
11f10 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
11f20 22 50 72 69 6e 74 69 6e 67 20 69 6e 66 6f 20 66 "Printing info f
11f30 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 20 or run " runkey
11f40 22 2c 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 ", run=" run ",
11f50 74 65 73 74 73 3d 22 20 74 65 73 74 73 20 22 2c tests=" tests ",
11f60 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 header=" header
11f70 29 0a 09 09 20 20 20 20 61 63 74 69 6f 6e 29 0a )... action).
11f80 09 09 20 20 20 28 28 72 75 6e 2d 77 61 69 74 29 .. ((run-wait)
11f90 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
11fa0 69 6e 74 20 31 20 22 57 61 69 74 69 6e 67 20 66 int 1 "Waiting f
11fb0 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 20 or run " runkey
11fc0 22 2c 20 72 75 6e 3d 22 20 72 75 6e 6e 61 6d 65 ", run=" runname
11fd0 70 61 74 74 20 22 20 74 6f 20 63 6f 6d 70 6c 65 patt " to comple
11fe0 74 65 22 29 29 0a 09 09 20 20 20 28 28 61 72 63 te"))... ((arc
11ff0 68 69 76 65 29 0a 09 09 20 20 20 20 28 64 65 62 hive)... (deb
12000 75 67 3a 70 72 69 6e 74 20 31 20 22 41 72 63 68 ug:print 1 "Arch
12010 69 76 69 6e 67 2f 72 65 73 74 6f 72 69 6e 67 20 iving/restoring
12020 28 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (" (args:get-arg
12030 20 22 2d 61 72 63 68 69 76 65 22 29 20 22 29 20 "-archive") ")
12040 64 61 74 61 20 66 6f 72 20 72 75 6e 3a 20 22 20 data for run: "
12050 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
12060 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
12070 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
12080 75 6e 6e 61 6d 65 22 29 29 0a 09 09 20 20 20 20 unname"))...
12090 28 73 65 74 21 20 77 6f 72 6b 65 72 2d 74 68 72 (set! worker-thr
120a0 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 ead (make-thread
120b0 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 (lambda ().....
120c0 09 09 20 20 20 20 20 20 20 28 63 61 73 65 20 28 .. (case (
120d0 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
120e0 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 args:get-arg "-a
120f0 72 63 68 69 76 65 22 29 29 0a 09 09 09 09 09 09 rchive")).......
12100 09 20 28 28 73 61 76 65 20 73 61 76 65 2d 72 65 . ((save save-re
12110 6d 6f 76 65 20 6b 65 65 70 2d 68 74 6d 6c 29 28 move keep-html)(
12120 61 72 63 68 69 76 65 3a 72 75 6e 2d 62 75 70 20 archive:run-bup
12130 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
12140 61 72 63 68 69 76 65 22 29 20 72 75 6e 2d 69 64 archive") run-id
12150 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 73 29 run-name tests)
12160 29 0a 09 09 09 09 09 09 09 20 28 28 72 65 73 74 )........ ((rest
12170 6f 72 65 29 28 61 72 63 68 69 76 65 3a 62 75 70 ore)(archive:bup
12180 2d 72 65 73 74 6f 72 65 20 28 61 72 67 73 3a 67 -restore (args:g
12190 65 74 2d 61 72 67 20 22 2d 61 72 63 68 69 76 65 et-arg "-archive
121a0 22 29 20 72 75 6e 2d 69 64 20 72 75 6e 2d 6e 61 ") run-id run-na
121b0 6d 65 20 74 65 73 74 73 29 29 0a 09 09 09 09 09 me tests))......
121c0 09 09 20 28 65 6c 73 65 20 0a 09 09 09 09 09 09 .. (else .......
121d0 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
121e0 30 20 22 45 52 52 4f 52 3a 20 75 6e 72 65 63 6f 0 "ERROR: unreco
121f0 67 6e 69 73 65 64 20 73 75 62 20 63 6f 6d 6d 61 gnised sub comma
12200 6e 64 20 74 6f 20 2d 61 72 63 68 69 76 65 2e 20 nd to -archive.
12210 52 75 6e 20 5c 22 6d 65 67 61 74 65 73 74 5c 22 Run \"megatest\"
12220 20 74 6f 20 73 65 65 20 68 65 6c 70 22 29 0a 09 to see help")..
12230 09 09 09 09 09 09 20 20 28 65 78 69 74 29 29 29 ...... (exit)))
12240 29 0a 09 09 09 09 09 09 20 20 20 20 20 22 61 72 )....... "ar
12250 63 68 69 76 65 2d 62 75 70 2d 74 68 72 65 61 64 chive-bup-thread
12260 22 29 29 0a 09 09 20 20 20 20 28 74 68 72 65 61 "))... (threa
12270 64 2d 73 74 61 72 74 21 20 77 6f 72 6b 65 72 2d d-start! worker-
12280 74 68 72 65 61 64 29 29 0a 09 09 20 20 20 28 65 thread))... (e
12290 6c 73 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 lse... (debug
122a0 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 :print-info 0 "a
122b0 63 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e ction not recogn
122c0 69 73 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 ised " action)))
122d0 0a 09 09 20 0a 09 09 20 3b 3b 20 61 63 74 69 6f ... ... ;; actio
122e0 6e 73 20 74 68 61 74 20 6f 70 65 72 61 74 65 20 ns that operate
122f0 6f 6e 20 6f 6e 65 20 74 65 73 74 20 61 74 20 61 on one test at a
12300 20 74 69 6d 65 20 63 61 6e 20 62 65 20 68 61 6e time can be han
12310 64 6c 65 64 20 62 65 6c 6f 77 0a 09 09 20 3b 3b dled below... ;;
12320 0a 09 09 20 28 6c 65 74 20 28 28 73 6f 72 74 65 ... (let ((sorte
12330 64 2d 74 65 73 74 73 20 20 20 20 20 28 66 69 6c d-tests (fil
12340 74 65 72 20 0a 09 09 09 09 09 20 20 76 65 63 74 ter ...... vect
12350 6f 72 3f 0a 09 09 09 09 09 20 20 28 73 6f 72 74 or?...... (sort
12360 20 74 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 tests (lambda (
12370 61 20 62 29 28 6c 65 74 20 28 28 64 69 72 61 20 a b)(let ((dira
12380 3b 3b 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 ;; (rmt:sdb-qry
12390 27 67 65 74 73 74 72 20 0a 09 09 09 09 09 09 09 'getstr ........
123a0 09 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
123b0 2d 72 75 6e 64 69 72 20 61 29 29 20 3b 3b 20 29 -rundir a)) ;; )
123c0 20 20 3b 3b 20 28 66 69 6c 65 64 62 3a 67 65 74 ;; (filedb:get
123d0 2d 70 61 74 68 20 2a 66 64 62 2a 20 28 64 62 3a -path *fdb* (db:
123e0 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
123f0 61 29 29 29 0a 09 09 09 09 09 09 09 09 09 20 28 a))).......... (
12400 64 69 72 62 20 3b 3b 20 28 72 6d 74 3a 73 64 62 dirb ;; (rmt:sdb
12410 2d 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 09 -qry 'getstr ...
12420 09 09 09 09 09 09 09 20 20 28 64 62 3a 74 65 73 ....... (db:tes
12430 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 t-get-rundir b))
12440 29 20 3b 3b 20 29 20 3b 3b 20 28 28 66 69 6c 65 ) ;; ) ;; ((file
12450 64 62 3a 67 65 74 2d 70 61 74 68 20 2a 66 64 62 db:get-path *fdb
12460 2a 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 * (db:test-get-r
12470 75 6e 64 69 72 20 62 29 29 29 29 0a 09 09 09 09 undir b)))).....
12480 09 09 09 09 20 20 20 20 20 28 69 66 20 28 61 6e .... (if (an
12490 64 20 28 73 74 72 69 6e 67 3f 20 64 69 72 61 29 d (string? dira)
124a0 28 73 74 72 69 6e 67 3f 20 64 69 72 62 29 29 0a (string? dirb)).
124b0 09 09 09 09 09 09 09 09 09 20 28 3e 20 28 73 74 ......... (> (st
124c0 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 ring-length dira
124d0 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 )(string-length
124e0 64 69 72 62 29 29 0a 09 09 09 09 09 09 09 09 09 dirb))..........
124f0 20 23 66 29 29 29 29 29 29 0a 09 09 20 20 20 20 #f))))))...
12500 20 20 20 28 74 6f 70 6c 65 76 65 6c 2d 72 65 74 (toplevel-ret
12510 72 69 65 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d ries (make-hash-
12520 74 61 62 6c 65 29 29 20 3b 3b 20 74 72 79 20 74 table)) ;; try t
12530 68 72 65 65 20 74 69 6d 65 73 20 74 6f 20 6c 6f hree times to lo
12540 6f 70 20 74 68 72 6f 75 67 68 20 61 6e 64 20 72 op through and r
12550 65 6d 6f 76 65 20 74 6f 70 20 6c 65 76 65 6c 20 emove top level
12560 74 65 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 tests... (
12570 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 test-retry-time
12580 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
12590 65 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 6c e))... (al
125a0 6c 6f 77 2d 72 75 6e 2d 74 69 6d 65 20 20 20 31 low-run-time 1
125b0 30 29 29 20 3b 3b 20 73 65 63 6f 6e 64 73 20 74 0)) ;; seconds t
125c0 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 6b 69 6c 6c o allow for kill
125d0 69 6e 67 20 74 65 73 74 73 20 62 65 66 6f 72 65 ing tests before
125e0 20 6a 75 73 74 20 62 72 75 74 61 6c 6c 79 20 6b just brutally k
125f0 69 6c 6c 69 6e 67 20 27 65 6d 0a 09 09 20 20 20 illing 'em...
12600 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 (let loop ((test
12610 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 73 (car sorted-tes
12620 74 73 29 29 0a 09 09 09 20 20 20 20 20 20 28 74 ts)).... (t
12630 61 6c 20 20 28 63 64 72 20 73 6f 72 74 65 64 2d al (cdr sorted-
12640 74 65 73 74 73 29 29 29 0a 09 09 20 20 20 20 20 tests)))...
12650 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 69 64 20 (let* ((test-id
12660 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
12670 65 74 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 et-id test))....
12680 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 64 61 (new-test-da
12690 74 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 t (rmt:get-test
126a0 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
126b0 69 64 20 74 65 73 74 2d 69 64 20 61 72 65 61 2d id test-id area-
126c0 64 61 74 29 29 29 0a 09 09 20 20 20 20 20 20 20 dat)))...
126d0 28 69 66 20 28 6e 6f 74 20 6e 65 77 2d 74 65 73 (if (not new-tes
126e0 74 2d 64 61 74 29 0a 09 09 09 20 20 20 28 62 65 t-dat).... (be
126f0 67 69 6e 0a 09 09 09 20 20 20 20 20 28 64 65 62 gin.... (deb
12700 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
12710 52 3a 20 57 65 20 68 61 76 65 20 61 20 74 65 73 R: We have a tes
12720 74 2d 69 64 20 6f 66 20 22 20 74 65 73 74 2d 69 t-id of " test-i
12730 64 20 22 20 62 75 74 20 6e 6f 20 72 65 63 6f 72 d " but no recor
12740 64 20 77 61 73 20 66 6f 75 6e 64 2e 20 4e 4f 54 d was found. NOT
12750 45 3a 20 4e 6f 20 6c 6f 63 6b 69 6e 67 20 6f 66 E: No locking of
12760 20 72 65 63 6f 72 64 73 20 69 73 20 64 6f 6e 65 records is done
12770 20 62 65 74 77 65 65 6e 20 70 72 6f 63 65 73 73 between process
12780 65 73 2c 20 64 6f 20 6e 6f 74 20 73 69 6d 75 6c es, do not simul
12790 74 61 6e 65 6f 75 73 6c 79 20 72 65 6d 6f 76 65 taneously remove
127a0 20 74 68 65 20 73 61 6d 65 20 72 75 6e 20 66 72 the same run fr
127b0 6f 6d 20 74 77 6f 20 70 72 6f 63 65 73 73 65 73 om two processes
127c0 21 22 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 !").... (if
127d0 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
127e0 29 0a 09 09 09 09 20 28 6c 6f 6f 70 20 28 63 61 )..... (loop (ca
127f0 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
12800 29 29 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 28 )).... (let* (
12810 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 28 (item-path (
12820 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
12830 2d 70 61 74 68 20 6e 65 77 2d 74 65 73 74 2d 64 -path new-test-d
12840 61 74 29 29 0a 09 09 09 09 20 20 28 74 65 73 74 at))..... (test
12850 2d 6e 61 6d 65 20 20 20 20 20 28 64 62 3a 74 65 -name (db:te
12860 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
12870 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 0a 09 new-test-dat))..
12880 09 09 09 20 20 28 72 75 6e 2d 64 69 72 20 20 20 ... (run-dir
12890 20 20 20 20 3b 3b 28 66 69 6c 65 64 62 3a 67 65 ;;(filedb:ge
128a0 74 2d 70 61 74 68 20 2a 66 64 62 2a 0a 09 09 09 t-path *fdb*....
128b0 09 20 20 20 3b 3b 20 28 72 6d 74 3a 73 64 62 2d . ;; (rmt:sdb-
128c0 71 72 79 20 27 67 65 74 69 64 20 0a 09 09 09 09 qry 'getid .....
128d0 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
128e0 72 75 6e 64 69 72 20 6e 65 77 2d 74 65 73 74 2d rundir new-test-
128f0 64 61 74 29 29 20 3b 3b 20 29 20 20 20 20 3b 3b dat)) ;; ) ;;
12900 20 72 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d run dir is from
12910 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 the link tree..
12920 09 09 09 20 20 28 74 65 73 74 2d 73 74 61 74 65 ... (test-state
12930 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
12940 2d 73 74 61 74 65 20 6e 65 77 2d 74 65 73 74 2d -state new-test-
12950 64 61 74 29 29 0a 09 09 09 09 20 20 28 74 65 73 dat))..... (tes
12960 74 2d 66 75 6c 6c 6e 20 20 20 20 28 64 62 3a 74 t-fulln (db:t
12970 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 6d 65 est-get-fullname
12980 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 29 0a new-test-dat)).
12990 09 09 09 09 20 20 28 75 6e 61 6d 65 20 20 20 20 .... (uname
129a0 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
129b0 74 2d 75 6e 61 6d 65 20 20 20 20 6e 65 77 2d 74 t-uname new-t
129c0 65 73 74 2d 64 61 74 29 29 0a 09 09 09 09 20 20 est-dat)).....
129d0 28 74 6f 70 6c 65 76 65 6c 2d 77 69 74 68 2d 63 (toplevel-with-c
129e0 68 69 6c 64 72 65 6e 20 28 61 6e 64 20 28 64 62 hildren (and (db
129f0 3a 74 65 73 74 2d 67 65 74 2d 69 73 2d 74 6f 70 :test-get-is-top
12a00 6c 65 76 65 6c 20 74 65 73 74 29 0a 09 09 09 09 level test).....
12a10 09 09 09 20 20 20 20 20 20 20 28 3e 20 28 72 6d ... (> (rm
12a20 74 3a 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d t:test-toplevel-
12a30 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 num-items run-id
12a40 20 74 65 73 74 2d 6e 61 6d 65 20 61 72 65 61 2d test-name area-
12a50 64 61 74 29 20 30 29 29 29 29 0a 09 09 09 20 20 dat) 0))))....
12a60 20 20 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a (case action.
12a70 09 09 09 20 20 20 20 20 20 20 28 28 72 65 6d 6f ... ((remo
12a80 76 65 2d 72 75 6e 73 29 0a 09 09 09 09 3b 3b 20 ve-runs).....;;
12a90 69 66 20 74 68 65 20 74 65 73 74 20 69 73 20 61 if the test is a
12aa0 20 74 6f 70 6c 65 76 65 6c 2d 77 69 74 68 2d 63 toplevel-with-c
12ab0 68 69 6c 64 72 65 6e 20 69 73 73 75 65 20 61 6e hildren issue an
12ac0 20 65 72 72 6f 72 20 61 6e 64 20 64 6f 20 6e 6f error and do no
12ad0 74 20 72 65 6d 6f 76 65 0a 09 09 09 09 28 69 66 t remove.....(if
12ae0 20 74 6f 70 6c 65 76 65 6c 2d 77 69 74 68 2d 63 toplevel-with-c
12af0 68 69 6c 64 72 65 6e 0a 09 09 09 09 20 20 20 20 hildren.....
12b00 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 (begin.....
12b10 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
12b20 22 57 41 52 4e 49 4e 47 3a 20 73 6b 69 70 70 69 "WARNING: skippi
12b30 6e 67 20 72 65 6d 6f 76 61 6c 20 6f 66 20 22 20 ng removal of "
12b40 74 65 73 74 2d 66 75 6c 6c 6e 20 22 20 77 69 74 test-fulln " wit
12b50 68 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 h run-id " run-i
12b60 64 20 22 20 61 73 20 69 74 20 68 61 73 20 73 75 d " as it has su
12b70 62 20 74 65 73 74 73 22 29 0a 09 09 09 09 20 20 b tests").....
12b80 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
12b90 73 65 74 21 20 74 6f 70 6c 65 76 65 6c 2d 72 65 set! toplevel-re
12ba0 74 72 69 65 73 20 74 65 73 74 2d 66 75 6c 6c 6e tries test-fulln
12bb0 20 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (+ (hash-table-
12bc0 72 65 66 2f 64 65 66 61 75 6c 74 20 74 6f 70 6c ref/default topl
12bd0 65 76 65 6c 2d 72 65 74 72 69 65 73 20 74 65 73 evel-retries tes
12be0 74 2d 66 75 6c 6c 6e 20 30 29 20 31 29 29 0a 09 t-fulln 0) 1))..
12bf0 09 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ... (if (>
12c00 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
12c10 74 6f 70 6c 65 76 65 6c 2d 72 65 74 72 69 65 73 toplevel-retries
12c20 20 74 65 73 74 2d 66 75 6c 6c 6e 29 20 33 29 0a test-fulln) 3).
12c30 09 09 09 09 09 20 20 28 69 66 20 28 6e 6f 74 20 ..... (if (not
12c40 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 (null? tal))....
12c50 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
12c60 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
12c70 29 29 20 3b 3b 20 6e 6f 20 65 6c 73 65 20 63 6c )) ;; no else cl
12c80 61 75 73 65 20 2d 20 64 72 6f 70 20 69 74 20 69 ause - drop it i
12c90 66 20 6e 6f 20 6d 6f 72 65 20 69 6e 20 71 75 65 f no more in que
12ca0 75 65 20 61 6e 64 20 3e 20 33 20 74 72 69 65 73 ue and > 3 tries
12cb0 0a 09 09 09 09 09 20 20 28 6c 65 74 20 28 28 6e ...... (let ((n
12cc0 65 77 74 61 6c 20 28 61 70 70 65 6e 64 20 74 61 ewtal (append ta
12cd0 6c 20 28 6c 69 73 74 20 74 65 73 74 29 29 29 29 l (list test))))
12ce0 0a 09 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 ...... (loop
12cf0 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
12d00 20 6e 65 77 74 61 6c 29 29 29 29 29 20 3b 3b 20 newtal))))) ;;
12d10 6c 6f 6f 70 20 77 69 74 68 20 74 65 73 74 20 73 loop with test s
12d20 74 69 6c 6c 20 69 6e 20 71 75 65 75 65 0a 09 09 till in queue...
12d30 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
12d40 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
12d50 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 int-info 0 "test
12d60 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 : " test-name "
12d70 69 74 65 73 74 2d 73 74 61 74 65 3a 20 22 20 74 itest-state: " t
12d80 65 73 74 2d 73 74 61 74 65 29 0a 09 09 09 09 20 est-state).....
12d90 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 (if (member
12da0 20 74 65 73 74 2d 73 74 61 74 65 20 28 6c 69 73 test-state (lis
12db0 74 20 22 52 55 4e 4e 49 4e 47 22 20 22 4c 41 55 t "RUNNING" "LAU
12dc0 4e 43 48 45 44 22 20 22 52 45 4d 4f 54 45 48 4f NCHED" "REMOTEHO
12dd0 53 54 53 54 41 52 54 22 20 22 4b 49 4c 4c 52 45 STSTART" "KILLRE
12de0 51 22 29 29 0a 09 09 09 09 09 20 20 28 62 65 67 Q"))...... (beg
12df0 69 6e 0a 09 09 09 09 09 20 20 20 20 28 69 66 20 in...... (if
12e00 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
12e10 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
12e20 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 74 65 73 t-retry-time tes
12e30 74 2d 66 75 6c 6c 6e 20 23 66 29 29 0a 09 09 09 t-fulln #f))....
12e40 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 09 ...(begin.......
12e50 20 20 3b 3b 20 77 61 6e 74 20 74 6f 20 73 65 74 ;; want to set
12e60 20 74 6f 20 52 45 4d 4f 56 49 4e 47 20 42 55 54 to REMOVING BUT
12e70 20 43 41 4e 4e 4f 54 20 64 6f 20 69 74 20 68 65 CANNOT do it he
12e80 72 65 3f 0a 09 09 09 09 09 09 20 20 28 68 61 73 re?....... (has
12e90 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
12ea0 74 2d 72 65 74 72 79 2d 74 69 6d 65 20 74 65 73 t-retry-time tes
12eb0 74 2d 66 75 6c 6c 6e 20 28 63 75 72 72 65 6e 74 t-fulln (current
12ec0 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 09 09 09 -seconds))))....
12ed0 09 09 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 .. (if (> (-
12ee0 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
12ef0 29 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 )(hash-table-ref
12f00 20 74 65 73 74 2d 72 65 74 72 79 2d 74 69 6d 65 test-retry-time
12f10 20 74 65 73 74 2d 66 75 6c 6c 6e 29 29 20 61 6c test-fulln)) al
12f20 6c 6f 77 2d 72 75 6e 2d 74 69 6d 65 29 0a 09 09 low-run-time)...
12f30 09 09 09 09 3b 3b 20 54 68 69 73 20 74 65 73 74 ....;; This test
12f40 20 69 73 20 6e 6f 74 20 69 6e 20 61 20 63 6f 72 is not in a cor
12f50 72 65 63 74 20 73 74 61 74 65 20 66 6f 72 20 63 rect state for c
12f60 6c 65 61 6e 69 6e 67 20 75 70 2e 20 4c 65 74 27 leaning up. Let'
12f70 73 20 74 72 79 20 73 6f 6d 65 20 67 72 61 63 65 s try some grace
12f80 66 75 6c 20 73 68 75 74 64 6f 77 6e 20 73 74 65 ful shutdown ste
12f90 70 73 20 66 69 72 73 74 0a 09 09 09 09 09 09 3b ps first.......;
12fa0 3b 20 53 65 74 20 74 68 65 20 74 65 73 74 20 74 ; Set the test t
12fb0 6f 20 22 4b 49 4c 4c 52 45 51 22 20 61 6e 64 20 o "KILLREQ" and
12fc0 77 61 69 74 20 66 69 76 65 20 73 65 63 6f 6e 64 wait five second
12fd0 73 20 74 68 65 6e 20 74 72 79 20 61 67 61 69 6e s then try again
12fe0 2e 20 52 65 70 65 61 74 20 75 70 20 74 6f 20 66 . Repeat up to f
12ff0 69 76 65 20 74 69 6d 65 73 20 74 68 65 6e 20 67 ive times then g
13000 69 76 65 0a 09 09 09 09 09 09 3b 3b 20 75 70 20 ive.......;; up
13010 61 6e 64 20 62 6c 6f 77 20 69 74 20 61 77 61 79 and blow it away
13020 2e 0a 09 09 09 09 09 09 28 62 65 67 69 6e 0a 09 ........(begin..
13030 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
13040 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
13050 63 6f 75 6c 64 20 6e 6f 74 20 67 72 61 63 65 66 could not gracef
13060 75 6c 6c 79 20 72 65 6d 6f 76 65 20 74 65 73 74 ully remove test
13070 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e 20 22 2c " test-fulln ",
13080 20 74 72 69 65 64 20 74 6f 20 6b 69 6c 6c 20 69 tried to kill i
13090 74 20 74 6f 20 6e 6f 20 61 76 61 69 6c 2e 20 46 t to no avail. F
130a0 6f 72 63 69 6e 67 20 73 74 61 74 65 20 74 6f 20 orcing state to
130b0 46 41 49 4c 45 44 4b 49 4c 4c 20 61 6e 64 20 63 FAILEDKILL and c
130c0 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 09 09 09 09 ontinuing").....
130d0 09 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 . (mt:test-se
130e0 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
130f0 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 64 62 3a y-id run-id (db:
13100 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
13110 29 20 22 46 41 49 4c 45 44 4b 49 4c 4c 22 20 22 ) "FAILEDKILL" "
13120 6e 2f 61 22 20 23 66 29 0a 09 09 09 09 09 09 20 n/a" #f).......
13130 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
13140 31 29 29 0a 09 09 09 09 09 09 28 62 65 67 69 6e 1)).......(begin
13150 0a 09 09 09 09 09 20 20 20 20 28 6d 74 3a 74 65 ...... (mt:te
13160 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
13170 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 tus-by-id run-id
13180 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
13190 20 74 65 73 74 29 20 22 4b 49 4c 4c 52 45 51 22 test) "KILLREQ"
131a0 20 22 6e 2f 61 22 20 23 66 29 0a 09 09 09 09 09 "n/a" #f)......
131b0 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
131c0 21 20 31 29 29 29 0a 09 09 09 09 09 20 20 20 20 ! 1)))......
131d0 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 ;; NOTE: This is
131e0 20 73 75 62 6f 70 74 69 6d 61 6c 20 61 73 20 74 suboptimal as t
131f0 68 65 20 74 65 73 74 64 61 74 61 20 77 69 6c 6c he testdata will
13200 20 62 65 20 75 73 65 64 20 6c 61 74 65 72 20 61 be used later a
13210 6e 64 20 74 68 65 20 73 74 61 74 65 2f 73 74 61 nd the state/sta
13220 74 75 73 20 6d 61 79 20 68 61 76 65 20 63 68 61 tus may have cha
13230 6e 67 65 64 20 2e 2e 2e 0a 09 09 09 09 09 20 20 nged .........
13240 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
13250 29 0a 09 09 09 09 09 09 28 6c 6f 6f 70 20 6e 65 ).......(loop ne
13260 77 2d 74 65 73 74 2d 64 61 74 20 74 61 6c 29 0a w-test-dat tal).
13270 09 09 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 ......(loop (car
13280 20 74 61 6c 29 28 61 70 70 65 6e 64 20 74 61 6c tal)(append tal
13290 20 28 6c 69 73 74 20 6e 65 77 2d 74 65 73 74 2d (list new-test-
132a0 64 61 74 29 29 29 29 29 0a 09 09 09 09 09 20 20 dat)))))......
132b0 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 (begin......
132c0 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d 74 65 73 (runs:remove-tes
132d0 74 2d 64 69 72 65 63 74 6f 72 79 20 6e 65 77 2d t-directory new-
132e0 74 65 73 74 2d 64 61 74 20 6d 6f 64 65 29 20 3b test-dat mode) ;
132f0 3b 20 27 72 65 6d 6f 76 65 2d 61 6c 6c 29 0a 09 ; 'remove-all)..
13300 09 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f 74 .... (if (not
13310 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
13320 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 ....(loop (car t
13330 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
13340 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 28 ))).... ((
13350 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
13360 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
13370 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 65 77 20 73 nt-info 2 "new s
13380 74 61 74 65 20 22 20 28 63 61 72 20 73 74 61 74 tate " (car stat
13390 65 2d 73 74 61 74 75 73 29 20 22 2c 20 6e 65 77 e-status) ", new
133a0 20 73 74 61 74 75 73 20 22 20 28 63 61 64 72 20 status " (cadr
133b0 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 state-status))..
133c0 09 09 09 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d ...(mt:test-set-
133d0 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
133e0 69 64 20 72 75 6e 2d 69 64 20 28 64 62 3a 74 65 id run-id (db:te
133f0 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
13400 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
13410 73 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 s)(cadr state-st
13420 61 74 75 73 29 20 23 66 29 0a 09 09 09 09 28 69 atus) #f).....(i
13430 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
13440 6c 29 29 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f l))..... (loo
13450 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
13460 74 61 6c 29 29 29 29 0a 09 09 09 20 20 20 20 20 tal))))....
13470 20 20 28 28 72 75 6e 2d 77 61 69 74 29 0a 09 09 ((run-wait)...
13480 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
13490 6e 66 6f 20 32 20 22 73 74 69 6c 6c 20 77 61 69 nfo 2 "still wai
134a0 74 69 6e 67 2c 20 22 20 28 6c 65 6e 67 74 68 20 ting, " (length
134b0 74 65 73 74 73 29 20 22 20 74 65 73 74 73 20 73 tests) " tests s
134c0 74 69 6c 6c 20 72 75 6e 6e 69 6e 67 22 29 0a 09 till running")..
134d0 09 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
134e0 21 20 31 30 29 0a 09 09 09 09 28 6c 65 74 20 28 ! 10).....(let (
134f0 28 6e 65 77 2d 74 65 73 74 73 20 28 70 72 6f 63 (new-tests (proc
13500 2d 67 65 74 2d 74 65 73 74 73 20 72 75 6e 2d 69 -get-tests run-i
13510 64 29 29 29 0a 09 09 09 09 20 20 28 69 66 20 28 d)))..... (if (
13520 6e 75 6c 6c 3f 20 6e 65 77 2d 74 65 73 74 73 29 null? new-tests)
13530 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
13540 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
13550 52 75 6e 20 63 6f 6d 70 6c 65 74 65 64 20 61 63 Run completed ac
13560 63 6f 72 64 69 6e 67 20 74 6f 20 7a 65 72 6f 20 cording to zero
13570 74 65 73 74 73 20 6d 61 74 63 68 69 6e 67 20 70 tests matching p
13580 72 6f 76 69 64 65 64 20 63 72 69 74 65 72 69 61 rovided criteria
13590 2e 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 6c .")..... (l
135a0 6f 6f 70 20 28 63 61 72 20 6e 65 77 2d 74 65 73 oop (car new-tes
135b0 74 73 29 28 63 64 72 20 6e 65 77 2d 74 65 73 74 ts)(cdr new-test
135c0 73 29 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 s)))))....
135d0 20 28 28 61 72 63 68 69 76 65 29 0a 09 09 09 09 ((archive).....
135e0 28 69 66 20 28 6e 6f 74 20 74 6f 70 6c 65 76 65 (if (not topleve
135f0 6c 2d 77 69 74 68 2d 63 68 69 6c 64 72 65 6e 29 l-with-children)
13600 0a 09 09 09 09 20 20 20 20 28 63 61 73 65 20 28 ..... (case (
13610 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
13620 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 args:get-arg "-a
13630 72 63 68 69 76 65 22 29 29 0a 09 09 09 09 20 20 rchive")).....
13640 20 20 20 20 28 28 73 61 76 65 20 73 61 76 65 2d ((save save-
13650 72 65 6d 6f 76 65 20 6b 65 65 70 2d 68 74 6d 6c remove keep-html
13660 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 )..... (de
13670 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
13680 20 22 45 73 74 69 6d 61 74 69 6e 67 20 64 69 73 "Estimating dis
13690 6b 20 73 70 61 63 65 20 75 73 61 67 65 20 66 6f k space usage fo
136a0 72 20 22 20 74 65 73 74 2d 66 75 6c 6c 6e 29 0a r " test-fulln).
136b0 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
136c0 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
136d0 20 20 20 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 " (common:get
136e0 2d 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 65 64 -disk-space-used
136f0 20 28 63 6f 6e 63 20 72 75 6e 2d 64 69 72 20 22 (conc run-dir "
13700 2f 22 29 29 29 29 29 29 0a 09 09 09 09 28 69 66 /")))))).....(if
13710 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
13720 29 29 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 ))..... (loop
13730 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
13740 61 6c 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 al))))....
13750 20 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 0a )))... ).
13760 09 09 20 20 20 20 20 28 69 66 20 77 6f 72 6b 65 .. (if worke
13770 72 2d 74 68 72 65 61 64 20 28 74 68 72 65 61 64 r-thread (thread
13780 2d 6a 6f 69 6e 21 20 77 6f 72 6b 65 72 2d 74 68 -join! worker-th
13790 72 65 61 64 29 29 29 29 29 29 0a 09 20 20 20 3b read)))))).. ;
137a0 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e ; remove the run
137b0 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 if zero tests r
137c0 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 emain.. (if (e
137d0 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 q? action 'remov
137e0 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 e-runs)..
137f0 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 (let ((remtests
13800 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f (mt:get-tests-fo
13810 72 2d 72 75 6e 20 28 64 62 3a 67 65 74 2d 76 61 r-run (db:get-va
13820 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
13830 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 20 23 n header "id") #
13840 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 20 27 f '("DELETED") '
13850 28 22 6e 2f 61 22 29 20 61 72 65 61 2d 64 61 74 ("n/a") area-dat
13860 20 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 not-in: #t)))..
13870 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d . (if (null? rem
13880 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 tests) ;; no mor
13890 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e e tests remainin
138a0 67 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 g... (let* (
138b0 28 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 (dparts (string
138c0 2d 73 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 -split lasttpath
138d0 20 22 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 "/")).... (r
138e0 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 unpath (conc "/"
138f0 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
13900 65 72 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b erse .......(tak
13910 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e e dparts (- (len
13920 67 74 68 20 64 70 61 72 74 73 29 20 31 29 29 0a gth dparts) 1)).
13930 09 09 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 ......"/"))))...
13940 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
13950 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
13960 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 run: " runkey "
13970 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d " (db:get-value-
13980 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
13990 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 ader "runname")
139a0 22 20 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 " and related re
139b0 63 6f 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 cord")...
139c0 28 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 (rmt:delete-run
139d0 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 29 run-id area-dat)
139e0 0a 09 09 20 20 20 20 20 20 20 28 72 6d 74 3a 64 ... (rmt:d
139f0 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 elete-old-delete
13a00 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 d-test-records a
13a10 72 65 61 2d 64 61 74 29 0a 09 09 20 20 20 20 20 rea-dat)...
13a20 20 20 3b 3b 20 28 72 6d 74 3a 73 65 74 2d 76 61 ;; (rmt:set-va
13a30 72 20 22 44 45 4c 45 54 45 44 5f 54 45 53 54 53 r "DELETED_TESTS
13a40 22 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e " (current-secon
13a50 64 73 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b ds))... ;;
13a60 20 6e 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 need to figure
13a70 6f 75 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 out the path to
13a80 74 68 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 the run dir and
13a90 72 65 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 remove it if emp
13aa0 74 79 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 ty... ;;
13ab0 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c (if (null? (gl
13ac0 6f 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 ob (conc runpath
13ad0 20 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 20 "/*")))...
13ae0 20 20 3b 3b 20 20 20 20 20 20 20 20 28 62 65 67 ;; (beg
13af0 69 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 in... ;; .
13b00 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
13b10 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 "Removing run di
13b20 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 r " runpath)...
13b30 20 20 20 20 20 20 3b 3b 20 09 20 28 73 79 73 74 ;; . (syst
13b40 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 em (conc "rmdir
13b50 2d 70 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 -p " runpath))))
13b60 0a 09 09 20 20 20 20 20 20 20 29 29 29 29 29 0a ... ))))).
13b70 09 20 29 29 0a 20 20 20 20 20 72 75 6e 73 29 0a . )). runs).
13b80 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a ;; (sqlite3:
13b90 66 69 6e 61 6c 69 7a 65 21 20 28 64 62 3a 64 65 finalize! (db:de
13ba0 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
13bb0 61 74 29 29 0a 20 20 20 20 29 0a 20 20 23 74 29 at)). ). #t)
13bc0 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
13bd0 72 65 6d 6f 76 65 2d 74 65 73 74 2d 64 69 72 65 remove-test-dire
13be0 63 74 6f 72 79 20 74 65 73 74 20 6d 6f 64 65 29 ctory test mode)
13bf0 20 3b 3b 20 72 65 6d 6f 76 65 2d 64 61 74 61 2d ;; remove-data-
13c00 6f 6e 6c 79 29 0a 20 20 28 6c 65 74 2a 20 28 28 only). (let* ((
13c10 72 75 6e 2d 64 69 72 20 20 20 20 20 20 20 28 64 run-dir (d
13c20 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
13c30 72 20 74 65 73 74 29 29 20 20 20 20 3b 3b 20 72 r test)) ;; r
13c40 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 un dir is from t
13c50 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 20 28 he link tree.. (
13c60 72 65 61 6c 2d 64 69 72 20 20 20 20 20 20 28 69 real-dir (i
13c70 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
13c80 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 run-dir)....
13c90 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
13ca0 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 e run-dir)....
13cb0 20 20 23 66 29 29 29 0a 20 20 20 20 28 63 61 73 #f))). (cas
13cc0 65 20 6d 6f 64 65 0a 20 20 20 20 20 20 28 28 72 e mode. ((r
13cd0 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 79 29 emove-data-only)
13ce0 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 (mt:test-set-sta
13cf0 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
13d00 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
13d10 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 73 _id test)(db:tes
13d20 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
13d30 43 4c 45 41 4e 49 4e 47 22 20 22 4c 4f 43 4b 45 CLEANING" "LOCKE
13d40 44 22 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 D" #f)). ((
13d50 72 65 6d 6f 76 65 2d 61 6c 6c 29 20 20 20 20 20 remove-all)
13d60 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (mt:test-set-st
13d70 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
13d80 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
13d90 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 65 n_id test)(db:te
13da0 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
13db0 22 52 45 4d 4f 56 49 4e 47 22 20 22 4c 4f 43 4b "REMOVING" "LOCK
13dc0 45 44 22 20 23 66 29 29 0a 20 20 20 20 20 20 28 ED" #f)). (
13dd0 28 61 72 63 68 69 76 65 2d 72 65 6d 6f 76 65 29 (archive-remove)
13de0 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (mt:test-set-s
13df0 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
13e00 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 d (db:test-get-r
13e10 75 6e 5f 69 64 20 74 65 73 74 29 28 64 62 3a 74 un_id test)(db:t
13e20 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
13e30 20 22 41 52 43 48 49 56 45 5f 52 45 4d 4f 56 49 "ARCHIVE_REMOVI
13e40 4e 47 22 20 23 66 20 23 66 29 29 29 0a 20 20 20 NG" #f #f))).
13e50 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
13e60 66 6f 20 31 20 22 41 74 74 65 6d 70 74 69 6e 67 fo 1 "Attempting
13e70 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 28 69 66 to remove " (if
13e80 20 72 65 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 real-dir (conc
13e90 22 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 " dir " real-dir
13ea0 20 22 20 61 6e 64 20 22 29 20 22 22 29 20 22 20 " and ") "") "
13eb0 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a link " run-dir).
13ec0 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 65 61 (if (and rea
13ed0 6c 2d 64 69 72 20 0a 09 20 20 20 20 20 28 3e 20 l-dir .. (>
13ee0 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 (string-length r
13ef0 65 61 6c 2d 64 69 72 29 20 35 29 0a 09 20 20 20 eal-dir) 5)..
13f00 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 (file-exists?
13f10 72 65 61 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 real-dir)) ;; ba
13f20 64 20 68 65 75 72 69 73 74 69 63 20 62 75 74 20 d heuristic but
13f30 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f should prevent /
13f40 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 tmp /home etc...
13f50 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 (begin ;; let* (
13f60 28 72 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c (realpath (resol
13f70 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d ve-pathname run-
13f80 64 69 72 29 29 29 0a 09 20 20 28 64 65 62 75 67 dir))).. (debug
13f90 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 :print-info 1 "R
13fa0 65 63 75 72 73 69 76 65 6c 79 20 72 65 6d 6f 76 ecursively remov
13fb0 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 29 0a ing " real-dir).
13fc0 09 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 . (if (file-exi
13fd0 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 0a 09 sts? real-dir)..
13fe0 20 20 20 20 20 20 28 72 75 6e 73 3a 73 61 66 65 (runs:safe
13ff0 2d 64 65 6c 65 74 65 2d 74 65 73 74 2d 64 69 72 -delete-test-dir
14000 20 72 65 61 6c 2d 64 69 72 29 0a 09 20 20 20 20 real-dir)..
14010 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
14020 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 "WARNING: test
14030 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 dir " real-dir "
14040 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 appears to not
14050 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 exist or is not
14060 72 65 61 64 61 62 6c 65 22 29 29 29 0a 09 28 69 readable")))..(i
14070 66 20 72 65 61 6c 2d 64 69 72 20 0a 09 20 20 20 f real-dir ..
14080 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
14090 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 63 74 "WARNING: direct
140a0 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 72 20 22 ory " real-dir "
140b0 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 22 does not exist"
140c0 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
140d0 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
140e0 6e 6f 20 72 65 61 6c 20 64 69 72 65 63 74 6f 72 no real director
140f0 79 20 63 6f 72 72 6f 73 70 6f 6e 64 69 6e 67 20 y corrosponding
14100 74 6f 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 to link " run-di
14110 72 20 22 2c 20 6e 6f 74 68 69 6e 67 20 64 6f 6e r ", nothing don
14120 65 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 73 e"))). (if (s
14130 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 ymbolic-link? ru
14140 6e 2d 64 69 72 29 0a 09 28 62 65 67 69 6e 0a 09 n-dir)..(begin..
14150 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
14160 6e 66 6f 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 nfo 1 "Removing
14170 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 symlink " run-di
14180 72 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 r).. (handle-ex
14190 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e ceptions.. exn
141a0 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
141b0 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 69 t 0 "ERROR: Fai
141c0 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 led to remove sy
141d0 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 mlink " run-dir
141e0 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
141f0 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
14200 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
14210 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 ) ", attempting
14220 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 20 to continue")..
14230 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 (delete-file r
14240 75 6e 2d 64 69 72 29 29 29 0a 09 28 69 66 20 28 un-dir)))..(if (
14250 64 69 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 directory? run-d
14260 69 72 29 0a 09 20 20 20 20 28 69 66 20 28 3e 20 ir).. (if (>
14270 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 (directory-fold
14280 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b 20 (lambda (f x)(+
14290 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 29 1 x)) 0 run-dir)
142a0 20 30 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 0)...(debug:pri
142b0 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 nt 0 "WARNING: r
142c0 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 efusing to remov
142d0 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 e " run-dir " as
142e0 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 it is not empty
142f0 22 29 0a 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 ")...(handle-exc
14300 65 70 74 69 6f 6e 73 0a 09 09 20 65 78 6e 0a 09 eptions... exn..
14310 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
14320 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
14330 20 74 6f 20 72 65 6d 6f 76 65 20 64 69 72 65 63 to remove direc
14340 74 6f 72 79 20 22 20 72 75 6e 2d 64 69 72 20 28 tory " run-dir (
14350 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
14360 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
14370 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
14380 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 ", attempting t
14390 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 20 o continue")...
143a0 28 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 (delete-director
143b0 79 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 20 20 y run-dir)))..
143c0 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e 2d 64 (if (and run-d
143d0 69 72 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 28 ir... (not (
143e0 6d 65 6d 62 65 72 20 72 75 6e 2d 64 69 72 20 28 member run-dir (
143f0 6c 69 73 74 20 22 6e 2f 61 22 20 22 2f 74 6d 70 list "n/a" "/tmp
14400 2f 62 61 64 6e 61 6d 65 22 29 29 29 29 0a 09 09 /badname"))))...
14410 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
14420 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 72 65 6d WARNING: not rem
14430 6f 76 69 6e 67 20 22 20 72 75 6e 2d 64 69 72 20 oving " run-dir
14440 22 20 61 73 20 69 74 20 65 69 74 68 65 72 20 64 " as it either d
14450 6f 65 73 6e 27 74 20 65 78 69 73 74 20 6f 72 20 oesn't exist or
14460 69 73 20 6e 6f 74 20 61 20 73 79 6d 6c 69 6e 6b is not a symlink
14470 22 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e ")...(debug:prin
14480 74 20 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 t 0 "NOTE: the r
14490 75 6e 20 64 69 72 20 66 6f 72 20 74 68 69 73 20 un dir for this
144a0 74 65 73 74 20 69 73 20 75 6e 64 65 66 69 6e 65 test is undefine
144b0 64 2e 20 54 65 73 74 20 6d 61 79 20 68 61 76 65 d. Test may have
144c0 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 64 65 already been de
144d0 6c 65 74 65 64 2e 22 29 29 0a 09 20 20 20 20 29 leted.")).. )
144e0 29 0a 20 20 20 20 3b 3b 20 4f 6e 6c 79 20 64 65 ). ;; Only de
144f0 6c 65 74 65 20 74 68 65 20 72 65 63 6f 72 64 73 lete the records
14500 20 2a 61 66 74 65 72 2a 20 72 65 6d 6f 76 69 6e *after* removin
14510 67 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 2e g the directory.
14520 20 49 66 20 74 68 69 6e 67 73 20 66 61 69 6c 20 If things fail
14530 77 65 20 68 61 76 65 20 61 20 72 65 63 6f 72 64 we have a record
14540 20 0a 20 20 20 20 28 63 61 73 65 20 6d 6f 64 65 . (case mode
14550 0a 20 20 20 20 20 20 28 28 72 65 6d 6f 76 65 2d . ((remove-
14560 64 61 74 61 2d 6f 6e 6c 79 29 28 6d 74 3a 74 65 data-only)(mt:te
14570 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
14580 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 65 tus-by-id (db:te
14590 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 65 st-get-run_id te
145a0 73 74 29 28 64 62 3a 74 65 73 74 2d 67 65 74 2d st)(db:test-get-
145b0 69 64 20 74 65 73 74 29 20 22 4e 4f 54 5f 53 54 id test) "NOT_ST
145c0 41 52 54 45 44 22 20 22 6e 2f 61 22 20 23 66 29 ARTED" "n/a" #f)
145d0 29 0a 20 20 20 20 20 20 28 28 61 72 63 68 69 76 ). ((archiv
145e0 65 2d 72 65 6d 6f 76 65 29 20 20 28 6d 74 3a 74 e-remove) (mt:t
145f0 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
14600 61 74 75 73 2d 62 79 2d 69 64 20 28 64 62 3a 74 atus-by-id (db:t
14610 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 est-get-run_id t
14620 65 73 74 29 28 64 62 3a 74 65 73 74 2d 67 65 74 est)(db:test-get
14630 2d 69 64 20 74 65 73 74 29 20 22 41 52 43 48 49 -id test) "ARCHI
14640 56 45 44 22 20 23 66 20 23 66 29 29 0a 20 20 20 VED" #f #f)).
14650 20 20 20 28 65 6c 73 65 20 28 72 6d 74 3a 64 65 (else (rmt:de
14660 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
14670 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 s (db:test-get-r
14680 75 6e 5f 69 64 20 74 65 73 74 29 20 28 64 62 3a un_id test) (db:
14690 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
146a0 29 20 61 72 65 61 2d 64 61 74 29 29 29 29 29 0a ) area-dat))))).
146b0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
146c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
146d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
146e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
146f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 =========.;; Rou
14700 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 tines for manipu
14710 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d lating runs.;;==
14720 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14730 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14740 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14750 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14760 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d ====..;; Since m
14770 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 any calls to a r
14780 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 74 74 un require prett
14790 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d 65 20 y much the same
147a0 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 setup .;; this w
147b0 72 61 70 70 65 72 20 69 73 20 75 73 65 64 20 74 rapper is used t
147c0 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 65 70 o reduce the rep
147d0 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 lication of code
147e0 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 61 .(define (genera
147f0 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 l-run-call switc
14800 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 hname action-des
14810 63 20 70 72 6f 63 20 61 72 65 61 2d 64 61 74 29 c proc area-dat)
14820 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d . (let ((runnam
14830 65 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 e (or (args:ge
14840 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
14850 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 )(args:get-arg "
14860 3a 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 28 74 :runname")))..(t
14870 61 72 67 65 74 20 20 20 20 28 63 6f 6d 6d 6f 6e arget (common
14880 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 :args-get-target
14890 29 29 0a 09 28 74 6f 70 70 61 74 68 20 20 20 28 ))..(toppath (
148a0 6d 65 67 61 74 65 73 74 3a 61 72 65 61 2d 70 61 megatest:area-pa
148b0 74 68 20 61 72 65 61 2d 64 61 74 29 29 0a 09 28 th area-dat))..(
148c0 63 6f 6e 66 69 67 64 61 74 20 28 6d 65 67 61 74 configdat (megat
148d0 65 73 74 3a 61 72 65 61 2d 63 6f 6e 66 69 67 64 est:area-configd
148e0 61 74 20 61 72 65 61 2d 64 61 74 29 29 0a 09 28 at area-dat))..(
148f0 63 6f 6e 66 69 67 69 6e 66 6f 20 28 6d 65 67 61 configinfo (mega
14900 74 65 73 74 3a 61 72 65 61 2d 63 6f 6e 66 69 67 test:area-config
14910 69 6e 66 6f 20 61 72 65 61 2d 64 61 74 29 29 29 info area-dat)))
14920 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
14930 28 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 ((not target).
14940 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
14950 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 0 "ERROR: Missi
14960 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 61 ng required para
14970 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 meter for " swit
14980 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 chname ", you mu
14990 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 74 st specify the t
149a0 61 72 67 65 74 20 77 69 74 68 20 2d 74 61 72 67 arget with -targ
149b0 65 74 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 et"). (exit
149c0 20 33 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 3)). ((not
149d0 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 runname). (
149e0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
149f0 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 RROR: Missing re
14a00 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 quired parameter
14a10 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d for " switchnam
14a20 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 e ", you must sp
14a30 65 63 69 66 79 20 74 68 65 20 72 75 6e 20 6e 61 ecify the run na
14a40 6d 65 20 77 69 74 68 20 2d 72 75 6e 6e 61 6d 65 me with -runname
14a50 20 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 runname").
14a60 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 (exit 3)).
14a70 28 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 (else. (let
14a80 20 28 3b 3b 20 28 64 62 20 20 20 23 66 29 0a 09 (;; (db #f)..
14a90 20 20 20 20 28 6b 65 79 73 20 23 66 29 29 0a 09 (keys #f))..
14aa0 28 69 66 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 (if (launch:setu
14ab0 70 2d 66 6f 72 2d 72 75 6e 20 61 72 65 61 2d 64 p-for-run area-d
14ac0 61 74 29 0a 09 20 20 20 20 28 6c 61 75 6e 63 68 at).. (launch
14ad0 3a 63 61 63 68 65 2d 63 6f 6e 66 69 67 20 61 72 :cache-config ar
14ae0 65 61 2d 64 61 74 29 0a 09 20 20 20 20 28 62 65 ea-dat).. (be
14af0 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 65 62 gin .. (deb
14b00 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c ug:print 0 "Fail
14b10 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 69 ed to setup, exi
14b20 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 65 ting").. (e
14b30 78 69 74 20 31 29 29 29 0a 09 28 73 65 74 21 20 xit 1)))..(set!
14b40 6b 65 79 73 20 28 6b 65 79 73 3a 63 6f 6e 66 69 keys (keys:confi
14b50 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 63 6f 6e g-get-fields con
14b60 66 69 67 64 61 74 29 29 0a 09 3b 3b 20 68 61 76 figdat))..;; hav
14b70 65 20 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 e enough to proc
14b80 65 73 73 20 2d 74 61 72 67 65 74 20 6f 72 20 2d ess -target or -
14b90 72 65 71 74 61 72 67 20 68 65 72 65 0a 09 28 69 reqtarg here..(i
14ba0 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
14bb0 22 2d 72 65 71 74 61 72 67 22 29 0a 09 20 20 20 "-reqtarg")..
14bc0 20 28 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 (let* ((runconf
14bd0 69 67 66 20 28 63 6f 6e 63 20 20 74 6f 70 70 61 igf (conc toppa
14be0 74 68 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e th "/runconfigs.
14bf0 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 config")) ;; DO
14c00 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c NOT EVALUATE ALL
14c10 20 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 ... (runconfi
14c20 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 g (read-config
14c30 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 74 runconfigf #f #t
14c40 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 environ-patt: #
14c50 66 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 f))).. (if
14c60 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
14c70 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 default runconfi
14c80 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 g (args:get-arg
14c90 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 0a "-reqtarg") #f).
14ca0 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 .. (keys:target
14cb0 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 -set-args keys (
14cc0 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
14cd0 65 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 eqtarg") args:ar
14ce0 67 2d 68 61 73 68 29 0a 09 09 20 20 20 20 0a 09 g-hash)... ..
14cf0 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
14d00 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
14d10 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a ERROR: [" (args:
14d20 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
14d30 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 g") "] not found
14d40 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 in " runconfigf
14d50 29 0a 09 09 20 20 20 20 3b 3b 20 28 69 66 20 64 )... ;; (if d
14d60 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c b (sqlite3:final
14d70 69 7a 65 21 20 64 62 29 29 0a 09 09 20 20 20 20 ize! db))...
14d80 28 65 78 69 74 20 31 29 0a 09 09 20 20 20 20 29 (exit 1)... )
14d90 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 )).. (if (arg
14da0 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
14db0 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 et")...(keys:tar
14dc0 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 get-set-args key
14dd0 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 s (args:get-arg
14de0 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 "-target" args:a
14df0 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 rg-hash) args:ar
14e00 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 g-hash)))..(if (
14e10 6e 6f 74 20 28 63 61 72 20 63 6f 6e 66 69 67 69 not (car configi
14e20 6e 66 6f 29 29 0a 09 20 20 20 20 28 62 65 67 69 nfo)).. (begi
14e30 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
14e40 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
14e50 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 Attempted to " a
14e60 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 ction-desc " but
14e70 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 run area config
14e80 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 file not found"
14e90 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 ).. (exit 1
14ea0 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 )).. ;; Extra
14eb0 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 ct out stuff nee
14ec0 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d ded in most or m
14ed0 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b any calls.. ;
14ee0 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c ; here then call
14ef0 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a proc.. (let*
14f00 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 28 6b ((keyvals (k
14f10 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
14f20 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
14f30 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 74 ).. (proc t
14f40 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 arget runname ke
14f50 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a 09 3b ys keyvals)))..;
14f60 3b 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 ; (if db (sqlite
14f70 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 3:finalize! db))
14f80 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 ..(set! *didsome
14f90 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a thing* #t)))))).
14fa0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
14fb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14fc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14fd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14fe0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 =========.;; Loc
14ff0 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b k/unlock runs.;;
15000 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15010 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15020 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15030 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15040 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
15050 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 (runs:handle-loc
15060 6b 69 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 king target keys
15070 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e runname lock un
15080 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 lock user). (le
15090 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 23 66 t* ((db #f
150a0 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 28 6d ).. (rundat (m
150b0 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 t:get-runs-by-pa
150c0 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 tt keys runname
150d0 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 target)).. (head
150e0 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 er (vector-ref
150f0 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 rundat 0)).. (r
15100 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d uns (vector-
15110 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a ref rundat 1))).
15120 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
15130 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c ambda (run)...(l
15140 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a et ((run-id (db:
15150 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
15160 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
15170 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 id")))... (if (
15180 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e or lock.... (an
15190 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 d unlock....
151a0 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 (begin..... (
151b0 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 print "Do you re
151c0 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c ally wish to unl
151d0 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 ock run " run-id
151e0 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a "?\n y/n: ").
151f0 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 .... (equal? "y"
15200 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 (read-line)))))
15210 0a 09 09 20 20 20 20 20 20 28 72 6d 74 3a 6c 6f ... (rmt:lo
15220 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 ck/unlock-run ru
15230 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b n-id lock unlock
15240 20 75 73 65 72 20 61 72 65 61 2d 64 61 74 29 0a user area-dat).
15250 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
15260 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 rint-info 0 "Ski
15270 70 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 pping lock/unloc
15280 6b 20 6f 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 k on " run-id)))
15290 29 0a 09 20 20 20 20 20 20 72 75 6e 73 29 29 29 ).. runs)))
152a0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
152b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c =========.;; Rol
152f0 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d lup runs.;;=====
15300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15310 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15320 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15330 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15340 3d 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 =..;; Update the
15350 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 test_meta table
15360 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 for this test.(
15370 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 define (runs:upd
15380 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 ate-test_meta te
15390 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
153a0 66 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 6c f area-dat). (l
153b0 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 et ((currrecord
153c0 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 (rmt:testmeta-ge
153d0 74 2d 72 65 63 6f 72 64 20 74 65 73 74 2d 6e 61 t-record test-na
153e0 6d 65 20 61 72 65 61 2d 64 61 74 29 29 29 0a 20 me area-dat))).
153f0 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 (if (not curr
15400 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a record)..(begin.
15410 09 20 20 28 73 65 74 21 20 63 75 72 72 72 65 63 . (set! currrec
15420 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 ord (make-vector
15430 20 31 31 20 23 66 29 29 0a 09 20 20 28 72 6d 74 11 #f)).. (rmt
15440 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 :testmeta-add-re
15450 63 6f 72 64 20 74 65 73 74 2d 6e 61 6d 65 20 61 cord test-name a
15460 72 65 61 2d 64 61 74 29 29 29 0a 20 20 20 20 28 rea-dat))). (
15470 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
15480 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 lambda (key).
15490 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 20 (let* ((idx
154a0 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 20 (cadr key))..
154b0 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b 65 (fld (car ke
154c0 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c 20 y)).. (val
154d0 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
154e0 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d est-conf "test_m
154f0 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 3b 3b eta" fld))).. ;;
15500 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
15510 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 66 6c "idx: " idx " fl
15520 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c 3a 20 d: " fld " val:
15530 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 61 6e " val).. (if (an
15540 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 d val (not (equa
15550 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 l? (vector-ref c
15560 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 76 urrrecord idx) v
15570 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 al))).. (beg
15580 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e in.. (prin
15590 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 65 t "Updating " te
155a0 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 st-name " " fld
155b0 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 " to " val)..
155c0 20 20 20 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 (rmt:testmet
155d0 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 74 a-update-field t
155e0 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c est-name fld val
155f0 20 61 72 65 61 2d 64 61 74 29 29 29 29 29 0a 20 area-dat))))).
15600 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 '(("author"
15610 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 2)("owner" 3)("d
15620 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 escription" 4)("
15630 72 65 76 69 65 77 65 64 22 20 35 29 28 22 74 61 reviewed" 5)("ta
15640 67 73 22 20 39 29 28 22 6a 6f 62 67 72 6f 75 70 gs" 9)("jobgroup
15650 22 20 31 30 29 29 29 29 29 0a 0a 3b 3b 20 55 70 " 10)))))..;; Up
15660 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 date test_meta f
15670 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 or all tests.(de
15680 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 fine (runs:updat
15690 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 e-all-test_meta
156a0 64 62 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 db area-dat). (
156b0 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 let ((test-names
156c0 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c 20 (tests:get-all
156d0 61 72 65 61 2d 64 61 74 29 29 29 20 3b 3b 20 28 area-dat))) ;; (
156e0 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d tests:get-valid-
156f0 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f tests))). (fo
15700 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
15710 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 mbda (test-name)
15720 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
15730 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 6d 74 test-conf (mt
15740 3a 6c 61 7a 79 2d 72 65 61 64 2d 74 65 73 74 2d :lazy-read-test-
15750 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 config test-name
15760 20 61 72 65 61 2d 64 61 74 29 29 29 0a 09 20 28 area-dat))).. (
15770 69 66 20 74 65 73 74 2d 63 6f 6e 66 20 28 72 75 if test-conf (ru
15780 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
15790 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 eta test-name te
157a0 73 74 2d 63 6f 6e 66 20 61 72 65 61 2d 64 61 74 st-conf area-dat
157b0 29 29 29 29 0a 20 20 20 20 20 28 68 61 73 68 2d )))). (hash-
157c0 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
157d0 6e 61 6d 65 73 29 29 29 29 0a 0a 3b 3b 20 54 68 names))))..;; Th
157e0 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c is could probabl
157f0 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 y be refactored
15800 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 into one complex
15810 20 71 75 65 72 79 20 2e 2e 2e 0a 3b 3b 20 4e 4f query ....;; NO
15820 54 20 50 4f 52 54 45 44 20 2d 20 44 4f 20 4e 4f T PORTED - DO NO
15830 54 20 55 53 45 20 59 45 54 0a 3b 3b 0a 28 64 65 T USE YET.;;.(de
15840 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 fine (runs:rollu
15850 70 2d 72 75 6e 20 6b 65 79 73 20 72 75 6e 6e 61 p-run keys runna
15860 6d 65 20 75 73 65 72 20 6b 65 79 76 61 6c 73 20 me user keyvals
15870 61 72 65 61 2d 64 61 74 29 0a 20 20 28 64 65 62 area-dat). (deb
15880 75 67 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 ug:print 4 "runs
15890 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 :rollup-run, key
158a0 73 3a 20 22 20 6b 65 79 73 20 22 20 2d 72 75 6e s: " keys " -run
158b0 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 name " runname "
158c0 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 user: " user).
158d0 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
158e0 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 3b #f).. ;
158f0 3b 20 72 65 67 69 73 74 65 72 20 72 75 6e 20 6f ; register run o
15900 70 65 72 61 74 65 73 20 6f 6e 20 74 68 65 20 6d perates on the m
15910 61 69 6e 20 64 62 0a 09 20 28 6e 65 77 2d 72 75 ain db.. (new-ru
15920 6e 2d 69 64 20 20 20 20 20 20 28 72 6d 74 3a 72 n-id (rmt:r
15930 65 67 69 73 74 65 72 2d 72 75 6e 20 6b 65 79 76 egister-run keyv
15940 61 6c 73 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 als runname "new
15950 22 20 22 6e 2f 61 22 20 75 73 65 72 20 61 72 65 " "n/a" user are
15960 61 2d 64 61 74 29 29 0a 09 20 28 70 72 65 76 2d a-dat)).. (prev-
15970 74 65 73 74 73 20 20 20 20 20 20 28 72 6d 74 3a tests (rmt:
15980 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 get-matching-pre
15990 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 vious-test-run-r
159a0 65 63 6f 72 64 73 20 6e 65 77 2d 72 75 6e 2d 69 ecords new-run-i
159b0 64 20 22 25 22 20 22 25 22 20 61 72 65 61 2d 64 d "%" "%" area-d
159c0 61 74 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 at)).. (curr-tes
159d0 74 73 20 20 20 20 20 20 28 6d 74 3a 67 65 74 2d ts (mt:get-
159e0 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 6e 65 tests-for-run ne
159f0 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 27 w-run-id "%/%" '
15a00 28 29 20 27 28 29 20 61 72 65 61 2d 64 61 74 29 () '() area-dat)
15a10 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 2d ).. (curr-tests-
15a20 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d hash (make-hash-
15a30 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 72 6d table))). (rm
15a40 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 t:update-run-eve
15a50 6e 74 5f 74 69 6d 65 20 6e 65 77 2d 72 75 6e 2d nt_time new-run-
15a60 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 20 id area-dat).
15a70 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c ;; index the al
15a80 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 ready saved test
15a90 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e s by testname an
15aa0 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 d itemdat in cur
15ab0 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 r-tests-hash.
15ac0 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
15ad0 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 (lambda (testdat
15ae0 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
15af0 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 (testname (db:t
15b00 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
15b10 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
15b20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 (item-path (db
15b30 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
15b40 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
15b50 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
15b60 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 (conc testname "
15b70 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a /" item-path))).
15b80 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
15b90 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
15ba0 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 sh full-name tes
15bb0 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 tdat))). cur
15bc0 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 r-tests). ;;
15bd0 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 NOPE: Non-optima
15be0 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 l approach. Try
15bf0 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 this instead..
15c00 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 ;; 1. tests
15c10 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 are received in
15c20 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 a list, most rec
15c30 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b ent first. ;;
15c40 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 2. replace th
15c50 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 e rollup test wi
15c60 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 th the new *alwa
15c70 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ys*. (for-eac
15c80 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
15c90 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 (testdat).
15ca0 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d (let* ((testnam
15cb0 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d e (db:test-get-
15cc0 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
15cd0 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d )).. (item-
15ce0 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 path (db:test-ge
15cf0 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
15d00 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 dat)).. (fu
15d10 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 ll-name (conc te
15d20 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
15d30 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 path)).. (p
15d40 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 rev-test-dat (ha
15d50 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
15d60 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d ault curr-tests-
15d70 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 hash full-name #
15d80 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
15d90 2d 73 74 65 70 73 20 20 20 20 28 72 6d 74 3a 67 -steps (rmt:g
15da0 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
15db0 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 t (db:test-get-i
15dc0 64 20 74 65 73 74 64 61 74 29 20 61 72 65 61 2d d testdat) area-
15dd0 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 6e 65 dat)).. (ne
15de0 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 w-test-record #f
15df0 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 )).. ;; replace
15e00 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 these with inser
15e10 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 t ... select.. (
15e20 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
15e30 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 ecute ...db ...(
15e40 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
15e50 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
15e60 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e ts (run_id,testn
15e70 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
15e80 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 ,event_time,host
15e90 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 ,cpuload,diskfre
15ea0 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 e,uname,rundir,i
15eb0 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 tem_path,run_dur
15ec0 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 ation,final_logf
15ed0 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
15ee0 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f "VALUES (?,?
15ef0 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
15f00 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e ,?,?,?,?);")...n
15f10 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 ew-run-id (cddr
15f20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 (vector->list te
15f30 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 stdat))).. (set!
15f40 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 new-testdat (ca
15f50 72 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d r (mt:get-tests-
15f60 66 6f 72 2d 72 75 6e 20 6e 65 77 2d 72 75 6e 2d for-run new-run-
15f70 69 64 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d id (conc testnam
15f80 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
15f90 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 68 '() '()))).. (h
15fa0 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
15fb0 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
15fc0 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 73 ull-name new-tes
15fd0 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 6f tdat) ;; this co
15fe0 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e 67 uld be confusing
15ff0 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 73 , which record s
16000 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 68 hould go into th
16010 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f 0a e lookup table?.
16020 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 . ;; Now duplica
16030 74 65 20 74 68 65 20 74 65 73 74 20 73 74 65 70 te the test step
16040 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 s.. (debug:print
16050 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 4 "Copying reco
16060 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 70 rds in test_step
16070 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 s from test_id="
16080 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
16090 20 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 testdat) " to "
160a0 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
160b0 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 new-testdat))..
160c0 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
160d0 20 3b 3b 20 74 6f 20 62 65 20 72 65 70 6c 61 63 ;; to be replac
160e0 65 64 2c 20 6e 6f 74 65 3a 20 74 68 69 73 20 72 ed, note: this r
160f0 6f 75 74 69 6e 65 20 69 73 20 6e 6f 74 20 75 73 outine is not us
16100 65 64 20 63 75 72 72 65 6e 74 6c 79 0a 09 20 20 ed currently..
16110 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 (lambda ()..
16120 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
16130 20 0a 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 .. db ..
16140 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 (conc "INSERT
16150 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 OR REPLACE INTO
16160 74 65 73 74 5f 73 74 65 70 73 20 28 74 65 73 74 test_steps (test
16170 5f 69 64 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 _id,stepname,sta
16180 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f te,status,event_
16190 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a time,comment) ".
161a0 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 28 .. "SELECT " (
161b0 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e db:test-get-id n
161c0 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 73 74 ew-testdat) ",st
161d0 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 epname,state,sta
161e0 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 tus,event_time,c
161f0 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 omment FROM test
16200 5f 73 74 65 70 73 20 57 48 45 52 45 20 74 65 73 _steps WHERE tes
16210 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 t_id=?;")..
16220 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
16230 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 3b testdat)).. ;
16240 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 20 ; Now duplicate
16250 74 68 65 20 74 65 73 74 20 64 61 74 61 0a 09 20 the test data..
16260 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
16270 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 4 "Copying recor
16280 64 73 20 69 6e 20 74 65 73 74 5f 64 61 74 61 20 ds in test_data
16290 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 from test_id=" (
162a0 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
162b0 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 estdat) " to " (
162c0 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e db:test-get-id n
162d0 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 20 ew-testdat))..
162e0 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
162f0 74 65 20 0a 09 20 20 20 20 20 64 62 20 0a 09 20 te .. db ..
16300 20 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 (conc "INSER
16310 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
16320 4f 20 74 65 73 74 5f 64 61 74 61 20 28 74 65 73 O test_data (tes
16330 74 5f 69 64 2c 63 61 74 65 67 6f 72 79 2c 76 61 t_id,category,va
16340 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
16350 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
16360 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 comment) "...
16370 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 "SELECT " (db:te
16380 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 st-get-id new-te
16390 73 74 64 61 74 29 20 22 2c 63 61 74 65 67 6f 72 stdat) ",categor
163a0 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 y,variable,value
163b0 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e ,expected,tol,un
163c0 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d its,comment FROM
163d0 20 74 65 73 74 5f 64 61 74 61 20 57 48 45 52 45 test_data WHERE
163e0 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 test_id=?;")..
163f0 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
16400 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 29 0a -id testdat)))).
16410 09 20 29 29 0a 20 20 20 20 20 70 72 65 76 2d 74 . )). prev-t
16420 65 73 74 73 29 29 29 0a 09 20 0a 20 20 20 20 20 ests))).. .
16430 0a .