Artifact
f8c5b58774bb71d70147005d2d135eb2cc6d2ad7
File
dashboard.scm
— part of check-in
[6c2fada4e9]
at
2013-04-12 09:39:43
on branch support-for-skip
— Added support for SKIP.
(user:
mrwellan
size: 25164)
[more...]
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 66 6f 72 6d 61 74 29 0a 28 72 65 71 75 69 72 format).(requir
01f0: 65 2d 6c 69 62 72 61 72 79 20 69 75 70 29 0a 28 e-library iup).(
0200: 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 69 import (prefix i
0210: 75 70 20 69 75 70 3a 29 29 0a 0a 28 75 73 65 20 up iup:))..(use
0220: 63 61 6e 76 61 73 2d 64 72 61 77 29 0a 0a 28 75 canvas-draw)..(u
0230: 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 69 2d se sqlite3 srfi-
0240: 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 72 65 1 posix regex re
0250: 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d 36 39 gex-case srfi-69
0260: 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 ).(import (prefi
0270: 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 x sqlite3 sqlite
0280: 33 3a 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 3:))..(declare (
0290: 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 uses common)).(d
02a0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 61 72 eclare (uses mar
02b0: 67 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 gs)).(declare (u
02c0: 73 65 73 20 6b 65 79 73 29 29 0a 28 64 65 63 6c ses keys)).(decl
02d0: 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 29 are (uses items)
02e0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
02f0: 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 db)).(declare (
0300: 75 73 65 73 20 63 6f 6e 66 69 67 66 29 29 0a 28 uses configf)).(
0310: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 70 72 declare (uses pr
0320: 6f 63 65 73 73 29 29 0a 28 64 65 63 6c 61 72 65 ocess)).(declare
0330: 20 28 75 73 65 73 20 6c 61 75 6e 63 68 29 29 0a (uses launch)).
0340: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 (declare (uses r
0350: 75 6e 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 uns)).(declare (
0360: 75 73 65 73 20 64 61 73 68 62 6f 61 72 64 2d 74 uses dashboard-t
0370: 65 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 ests)).(declare
0380: 28 75 73 65 73 20 64 61 73 68 62 6f 61 72 64 2d (uses dashboard-
0390: 67 75 69 6d 6f 6e 69 74 6f 72 29 29 0a 3b 3b 20 guimonitor)).;;
03a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
03b0: 61 73 68 62 6f 61 72 64 2d 6d 61 69 6e 29 29 0a ashboard-main)).
03c0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d (declare (uses m
03d0: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 29 egatest-version)
03e0: 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d )..(include "com
03f0: 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 mon_records.scm"
0400: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0410: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0420: 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 clude "run_recor
0430: 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e ds.scm")..(defin
0440: 65 20 68 65 6c 70 20 28 63 6f 6e 63 20 0a 22 4d e help (conc ."M
0450: 65 67 61 74 65 73 74 20 44 61 73 68 62 6f 61 72 egatest Dashboar
0460: 64 2c 20 64 6f 63 75 6d 65 6e 74 61 74 69 6f 6e d, documentation
0470: 20 61 74 20 68 74 74 70 3a 2f 2f 77 77 77 2e 6b at http://www.k
0480: 69 61 74 6f 61 2e 63 6f 6d 2f 66 6f 73 73 69 6c iatoa.com/fossil
0490: 73 2f 6d 65 67 61 74 65 73 74 0a 20 20 76 65 72 s/megatest. ver
04a0: 73 69 6f 6e 20 22 20 6d 65 67 61 74 65 73 74 2d sion " megatest-
04b0: 76 65 72 73 69 6f 6e 20 22 0a 20 20 6c 69 63 65 version ". lice
04c0: 6e 73 65 20 47 50 4c 2c 20 43 6f 70 79 72 69 67 nse GPL, Copyrig
04d0: 68 74 20 28 43 29 20 4d 61 74 74 20 57 65 6c 6c ht (C) Matt Well
04e0: 61 6e 64 20 32 30 31 31 0a 0a 55 73 61 67 65 3a and 2011..Usage:
04f0: 20 64 61 73 68 62 6f 61 72 64 20 5b 6f 70 74 69 dashboard [opti
0500: 6f 6e 73 5d 0a 20 20 2d 68 20 20 20 20 20 20 20 ons]. -h
0510: 20 20 20 20 20 20 20 20 20 3a 20 74 68 69 73 20 : this
0520: 68 65 6c 70 0a 20 20 2d 73 65 72 76 65 72 20 68 help. -server h
0530: 6f 73 74 3a 70 6f 72 74 20 3a 20 63 6f 6e 6e 65 ost:port : conne
0540: 63 74 20 74 6f 20 68 6f 73 74 3a 70 6f 72 74 20 ct to host:port
0550: 69 6e 73 74 65 61 64 20 6f 66 20 64 62 20 61 63 instead of db ac
0560: 63 65 73 73 0a 20 20 2d 74 65 73 74 20 74 65 73 cess. -test tes
0570: 74 69 64 20 20 20 20 20 20 3a 20 63 6f 6e 74 72 tid : contr
0580: 6f 6c 20 74 65 73 74 20 69 64 65 6e 74 69 66 69 ol test identifi
0590: 65 64 20 62 79 20 74 65 73 74 69 64 0a 20 20 2d ed by testid. -
05a0: 67 75 69 6d 6f 6e 69 74 6f 72 20 20 20 20 20 20 guimonitor
05b0: 20 3a 20 63 6f 6e 74 72 6f 6c 20 70 61 6e 65 6c : control panel
05c0: 20 66 6f 72 20 72 75 6e 73 0a 0a 4d 69 73 63 0a for runs..Misc.
05d0: 20 20 2d 72 6f 77 73 20 4e 20 20 20 20 20 20 20 -rows N
05e0: 20 20 3a 20 73 65 74 20 6e 75 6d 62 65 72 20 6f : set number o
05f0: 66 20 72 6f 77 73 0a 22 29 29 0a 0a 3b 3b 20 70 f rows."))..;; p
0600: 72 6f 63 65 73 73 20 61 72 67 73 0a 28 64 65 66 rocess args.(def
0610: 69 6e 65 20 72 65 6d 61 72 67 73 20 28 61 72 67 ine remargs (arg
0620: 73 3a 67 65 74 2d 61 72 67 73 20 0a 09 09 20 28 s:get-args ... (
0630: 61 72 67 76 29 0a 09 09 20 28 6c 69 73 74 20 20 argv)... (list
0640: 22 2d 72 6f 77 73 22 0a 09 09 09 22 2d 72 75 6e "-rows"...."-run
0650: 22 0a 09 09 09 22 2d 74 65 73 74 22 0a 09 09 09 "...."-test"....
0660: 22 2d 64 65 62 75 67 22 0a 09 09 09 22 2d 68 6f "-debug"...."-ho
0670: 73 74 22 20 0a 09 09 09 29 20 0a 09 09 20 28 6c st" ....) ... (l
0680: 69 73 74 20 20 22 2d 68 22 0a 09 09 09 22 2d 75 ist "-h"...."-u
0690: 73 65 2d 73 65 72 76 65 72 22 0a 09 09 09 22 2d se-server"...."-
06a0: 67 75 69 6d 6f 6e 69 74 6f 72 22 0a 09 09 09 22 guimonitor"...."
06b0: 2d 6d 61 69 6e 22 0a 09 09 09 22 2d 76 22 0a 09 -main"...."-v"..
06c0: 09 09 22 2d 71 22 0a 09 09 20 20 20 20 20 20 20 .."-q"...
06d0: 29 0a 09 09 20 61 72 67 73 3a 61 72 67 2d 68 61 )... args:arg-ha
06e0: 73 68 0a 09 09 20 30 29 29 0a 0a 28 69 66 20 28 sh... 0))..(if (
06f0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 68 args:get-arg "-h
0700: 22 29 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 "). (begin.
0710: 20 20 20 20 28 70 72 69 6e 74 20 68 65 6c 70 29 (print help)
0720: 0a 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a . (exit))).
0730: 0a 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 70 .(if (not (setup
0740: 2d 66 6f 72 2d 72 75 6e 29 29 0a 20 20 20 20 28 -for-run)). (
0750: 62 65 67 69 6e 0a 20 20 20 20 20 20 28 70 72 69 begin. (pri
0760: 6e 74 20 22 46 61 69 6c 65 64 20 74 6f 20 66 69 nt "Failed to fi
0770: 6e 64 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 nd megatest.conf
0780: 69 67 2c 20 65 78 69 74 69 6e 67 22 29 20 0a 20 ig, exiting") .
0790: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a (exit 1))).
07a0: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2a 20 23 66 .(define *db* #f
07b0: 29 20 3b 3b 20 28 6f 70 65 6e 2d 64 62 29 29 0a ) ;; (open-db)).
07c0: 0a 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 .(if (args:get-a
07d0: 72 67 20 22 2d 68 6f 73 74 22 29 0a 20 20 20 20 rg "-host").
07e0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 28 73 65 (begin. (se
07f0: 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 t! *runremote* (
0800: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 61 72 string-split (ar
0810: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 68 6f 73 gs:get-arg "-hos
0820: 74 22 20 22 3a 22 29 29 29 0a 20 20 20 20 20 20 t" ":"))).
0830: 28 63 6c 69 65 6e 74 3a 6c 61 75 6e 63 68 29 29 (client:launch))
0840: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 . (if (not (a
0850: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 75 73 rgs:get-arg "-us
0860: 65 2d 73 65 72 76 65 72 22 29 29 0a 09 28 73 65 e-server"))..(se
0870: 74 21 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 t! *transport-ty
0880: 70 65 2a 20 27 66 73 29 20 3b 3b 20 66 6f 72 63 pe* 'fs) ;; forc
0890: 65 20 66 73 20 61 63 63 65 73 73 0a 09 28 63 6c e fs access..(cl
08a0: 69 65 6e 74 3a 6c 61 75 6e 63 68 29 29 29 0a 0a ient:launch)))..
08b0: 3b 3b 20 48 41 43 4b 20 41 4c 45 52 54 3a 20 74 ;; HACK ALERT: t
08c0: 68 69 73 20 69 73 20 61 20 68 61 63 6b 2c 20 70 his is a hack, p
08d0: 6c 65 61 73 65 20 66 69 78 2e 0a 28 64 65 66 69 lease fix..(defi
08e0: 6e 65 20 2a 72 65 61 64 2d 6f 6e 6c 79 2a 20 28 ne *read-only* (
08f0: 6e 6f 74 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 not (file-read-a
0900: 63 63 65 73 73 3f 20 28 63 6f 6e 63 20 2a 74 6f ccess? (conc *to
0910: 70 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 65 73 ppath* "/megates
0920: 74 2e 64 62 22 29 29 29 29 0a 3b 3b 20 28 63 6c t.db")))).;; (cl
0930: 69 65 6e 74 3a 73 65 74 75 70 20 2a 64 62 2a 29 ient:setup *db*)
0940: 0a 0a 28 64 65 66 69 6e 65 20 74 6f 70 6c 65 76 ..(define toplev
0950: 65 6c 20 23 66 29 0a 28 64 65 66 69 6e 65 20 64 el #f).(define d
0960: 6c 67 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 lg #f).(def
0970: 69 6e 65 20 6d 61 78 2d 74 65 73 74 2d 6e 75 6d ine max-test-num
0980: 20 30 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a 0).;; (define *
0990: 6b 65 79 73 2a 20 20 20 28 6f 70 65 6e 2d 72 75 keys* (open-ru
09a0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 6b n-close db:get-k
09b0: 65 79 73 20 23 66 29 29 0a 28 64 65 66 69 6e 65 eys #f)).(define
09c0: 20 2a 6b 65 79 73 2a 20 20 20 28 63 64 62 3a 72 *keys* (cdb:r
09d0: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 emote-run db:get
09e0: 2d 6b 65 79 73 20 23 66 29 29 0a 3b 3b 20 28 64 -keys #f)).;; (d
09f0: 65 66 69 6e 65 20 2a 6b 65 79 73 2a 20 20 20 28 efine *keys* (
0a00: 64 62 3a 67 65 74 2d 6b 65 79 73 20 20 20 2a 64 db:get-keys *d
0a10: 62 2a 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 b*)).(define *db
0a20: 6b 65 79 73 2a 20 20 28 6d 61 70 20 28 6c 61 6d keys* (map (lam
0a30: 62 64 61 20 28 78 29 28 76 65 63 74 6f 72 2d 72 bda (x)(vector-r
0a40: 65 66 20 78 20 30 29 29 0a 09 09 20 20 20 20 20 ef x 0))...
0a50: 20 28 61 70 70 65 6e 64 20 2a 6b 65 79 73 2a 20 (append *keys*
0a60: 28 6c 69 73 74 20 28 76 65 63 74 6f 72 20 22 72 (list (vector "r
0a70: 75 6e 6e 61 6d 65 22 20 22 62 6c 61 68 22 29 29 unname" "blah"))
0a80: 29 29 29 0a 28 64 65 66 69 6e 65 20 2a 68 65 61 ))).(define *hea
0a90: 64 65 72 2a 20 20 20 20 20 20 20 23 66 29 0a 28 der* #f).(
0aa0: 64 65 66 69 6e 65 20 2a 61 6c 6c 72 75 6e 73 2a define *allruns*
0ab0: 20 20 20 20 20 27 28 29 29 0a 28 64 65 66 69 6e '()).(defin
0ac0: 65 20 2a 61 6c 6c 72 75 6e 73 2d 62 79 2d 69 64 e *allruns-by-id
0ad0: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
0ae0: 6c 65 29 29 20 3b 3b 20 0a 28 64 65 66 69 6e 65 le)) ;; .(define
0af0: 20 2a 72 75 6e 63 68 61 6e 67 65 72 61 74 65 2a *runchangerate*
0b00: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0b10: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 62 75 e))..(define *bu
0b20: 74 74 6f 6e 64 61 74 2a 20 20 20 20 28 6d 61 6b ttondat* (mak
0b30: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
0b40: 3b 20 3c 72 75 6e 2d 69 64 20 63 6f 6c 6f 72 20 ; <run-id color
0b50: 74 65 78 74 20 74 65 73 74 20 72 75 6e 2d 6b 65 text test run-ke
0b60: 79 3e 0a 28 64 65 66 69 6e 65 20 2a 61 6c 6c 74 y>.(define *allt
0b70: 65 73 74 6e 61 6d 65 6c 73 74 2a 20 27 28 29 29 estnamelst* '())
0b80: 0a 28 64 65 66 69 6e 65 20 2a 73 65 61 72 63 68 .(define *search
0b90: 70 61 74 74 73 2a 20 20 28 6d 61 6b 65 2d 68 61 patts* (make-ha
0ba0: 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 sh-table)).(defi
0bb0: 6e 65 20 2a 6e 75 6d 2d 72 75 6e 73 2a 20 20 20 ne *num-runs*
0bc0: 20 20 20 38 29 0a 28 64 65 66 69 6e 65 20 2a 74 8).(define *t
0bd0: 6f 74 2d 72 75 6e 2d 63 6f 75 6e 74 2a 20 28 63 ot-run-count* (c
0be0: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
0bf0: 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 23 66 :get-num-runs #f
0c00: 20 22 25 22 29 29 0a 3b 3b 20 28 64 65 66 69 6e "%")).;; (defin
0c10: 65 20 2a 74 6f 74 2d 72 75 6e 2d 63 6f 75 6e 74 e *tot-run-count
0c20: 2a 20 28 64 62 3a 67 65 74 2d 6e 75 6d 2d 72 75 * (db:get-num-ru
0c30: 6e 73 20 2a 64 62 2a 20 22 25 22 29 29 0a 28 64 ns *db* "%")).(d
0c40: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 75 70 64 61 efine *last-upda
0c50: 74 65 2a 20 20 20 28 63 75 72 72 65 6e 74 2d 73 te* (current-s
0c60: 65 63 6f 6e 64 73 29 29 0a 28 64 65 66 69 6e 65 econds)).(define
0c70: 20 2a 6e 75 6d 2d 74 65 73 74 73 2a 20 20 20 20 *num-tests*
0c80: 20 31 35 29 0a 28 64 65 66 69 6e 65 20 2a 73 74 15).(define *st
0c90: 61 72 74 2d 72 75 6e 2d 6f 66 66 73 65 74 2a 20 art-run-offset*
0ca0: 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 73 74 61 0).(define *sta
0cb0: 72 74 2d 74 65 73 74 2d 6f 66 66 73 65 74 2a 20 rt-test-offset*
0cc0: 30 29 0a 28 64 65 66 69 6e 65 20 2a 65 78 61 6d 0).(define *exam
0cd0: 69 6e 65 2d 74 65 73 74 2d 64 61 74 2a 20 28 6d ine-test-dat* (m
0ce0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0cf0: 0a 28 64 65 66 69 6e 65 20 2a 65 78 69 74 2d 73 .(define *exit-s
0d00: 74 61 72 74 65 64 2a 20 23 66 29 0a 28 64 65 66 tarted* #f).(def
0d10: 69 6e 65 20 2a 73 74 61 74 75 73 2d 69 67 6e 6f ine *status-igno
0d20: 72 65 2d 68 61 73 68 2a 20 28 6d 61 6b 65 2d 68 re-hash* (make-h
0d30: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
0d40: 69 6e 65 20 2a 73 74 61 74 65 2d 69 67 6e 6f 72 ine *state-ignor
0d50: 65 2d 68 61 73 68 2a 20 20 28 6d 61 6b 65 2d 68 e-hash* (make-h
0d60: 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 ash-table))..(de
0d70: 66 69 6e 65 20 2a 6c 61 73 74 2d 64 62 2d 75 70 fine *last-db-up
0d80: 64 61 74 65 2d 74 69 6d 65 2a 20 30 29 0a 28 64 date-time* 0).(d
0d90: 65 66 69 6e 65 20 2a 70 6c 65 61 73 65 2d 75 70 efine *please-up
0da0: 64 61 74 65 2d 62 75 74 74 6f 6e 73 2a 20 23 74 date-buttons* #t
0db0: 29 0a 28 64 65 66 69 6e 65 20 2a 64 65 6c 61 79 ).(define *delay
0dc0: 65 64 2d 75 70 64 61 74 65 2a 20 30 29 0a 0a 28 ed-update* 0)..(
0dd0: 64 65 66 69 6e 65 20 2a 64 62 2d 66 69 6c 65 2d define *db-file-
0de0: 70 61 74 68 2a 20 28 63 6f 6e 63 20 2a 74 6f 70 path* (conc *top
0df0: 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 65 73 74 path* "/megatest
0e00: 2e 64 62 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 .db"))..(define
0e10: 2a 74 65 73 74 73 2d 73 6f 72 74 2d 72 65 76 65 *tests-sort-reve
0e20: 72 73 65 2a 20 23 66 29 0a 28 64 65 66 69 6e 65 rse* #f).(define
0e30: 20 2a 68 69 64 65 2d 65 6d 70 74 79 2d 72 75 6e *hide-empty-run
0e40: 73 2a 20 23 66 29 0a 0a 28 64 65 62 75 67 3a 73 s* #f)..(debug:s
0e50: 65 74 75 70 29 0a 0a 28 64 65 66 69 6e 65 20 75 etup)..(define u
0e60: 69 64 61 74 20 23 66 29 0a 0a 28 64 65 66 69 6e idat #f)..(defin
0e70: 65 2d 69 6e 6c 69 6e 65 20 28 64 62 6f 61 72 64 e-inline (dboard
0e80: 3a 75 69 64 61 74 2d 67 65 74 2d 6b 65 79 63 6f :uidat-get-keyco
0e90: 6c 20 20 76 65 63 29 28 76 65 63 74 6f 72 2d 72 l vec)(vector-r
0ea0: 65 66 20 76 65 63 20 30 29 29 0a 28 64 65 66 69 ef vec 0)).(defi
0eb0: 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 62 6f 61 72 ne-inline (dboar
0ec0: 64 3a 75 69 64 61 74 2d 67 65 74 2d 6c 66 74 63 d:uidat-get-lftc
0ed0: 6f 6c 20 20 76 65 63 29 28 76 65 63 74 6f 72 2d ol vec)(vector-
0ee0: 72 65 66 20 76 65 63 20 31 29 29 0a 28 64 65 66 ref vec 1)).(def
0ef0: 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 62 6f 61 ine-inline (dboa
0f00: 72 64 3a 75 69 64 61 74 2d 67 65 74 2d 68 65 61 rd:uidat-get-hea
0f10: 64 65 72 20 20 76 65 63 29 28 76 65 63 74 6f 72 der vec)(vector
0f20: 2d 72 65 66 20 76 65 63 20 32 29 29 0a 28 64 65 -ref vec 2)).(de
0f30: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 62 6f fine-inline (dbo
0f40: 61 72 64 3a 75 69 64 61 74 2d 67 65 74 2d 72 75 ard:uidat-get-ru
0f50: 6e 73 76 65 63 20 76 65 63 29 28 76 65 63 74 6f nsvec vec)(vecto
0f60: 72 2d 72 65 66 20 76 65 63 20 33 29 29 0a 0a 0a r-ref vec 3))...
0f70: 28 64 65 66 69 6e 65 20 28 6d 65 73 73 61 67 65 (define (message
0f80: 2d 77 69 6e 64 6f 77 20 6d 73 67 29 0a 20 20 28 -window msg). (
0f90: 69 75 70 3a 73 68 6f 77 0a 20 20 20 28 69 75 70 iup:show. (iup
0fa0: 3a 64 69 61 6c 6f 67 0a 20 20 20 20 28 69 75 70 :dialog. (iup
0fb0: 3a 76 62 6f 78 20 0a 20 20 20 20 20 28 69 75 70 :vbox . (iup
0fc0: 3a 6c 61 62 65 6c 20 6d 73 67 20 23 3a 6d 61 72 :label msg #:mar
0fd0: 67 69 6e 20 22 34 30 78 34 30 22 29 29 29 29 29 gin "40x40")))))
0fe0: 0a 0a 28 64 65 66 69 6e 65 20 28 69 75 70 6c 69 ..(define (iupli
0ff0: 73 74 62 6f 78 2d 66 69 6c 6c 2d 6c 69 73 74 20 stbox-fill-list
1000: 6c 62 20 69 74 65 6d 73 20 2e 20 64 65 66 61 75 lb items . defau
1010: 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 69 20 31 lt). (let ((i 1
1020: 29 0a 09 28 73 65 6c 65 63 74 65 64 2d 69 74 65 )..(selected-ite
1030: 6d 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 m (if (null? def
1040: 61 75 6c 74 29 20 23 66 20 28 63 61 72 20 64 65 ault) #f (car de
1050: 66 61 75 6c 74 29 29 29 29 0a 20 20 20 20 28 69 fault)))). (i
1060: 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 up:attribute-set
1070: 21 20 6c 62 20 22 56 41 4c 55 45 22 20 28 69 66 ! lb "VALUE" (if
1080: 20 73 65 6c 65 63 74 65 64 2d 69 74 65 6d 20 73 selected-item s
1090: 65 6c 65 63 74 65 64 2d 69 74 65 6d 20 22 22 29 elected-item "")
10a0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
10b0: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 (lambda (item)..
10c0: 09 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 2d .(iup:attribute-
10d0: 73 65 74 21 20 6c 62 20 28 6e 75 6d 62 65 72 2d set! lb (number-
10e0: 3e 73 74 72 69 6e 67 20 69 29 20 69 74 65 6d 29 >string i) item)
10f0: 0a 09 09 28 69 66 20 73 65 6c 65 63 74 65 64 2d ...(if selected-
1100: 69 74 65 6d 0a 09 09 20 20 20 20 28 69 66 20 28 item... (if (
1110: 65 71 75 61 6c 3f 20 73 65 6c 65 63 74 65 64 2d equal? selected-
1120: 69 74 65 6d 20 69 74 65 6d 29 0a 09 09 09 28 69 item item)....(i
1130: 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 up:attribute-set
1140: 21 20 6c 62 20 22 56 41 4c 55 45 22 20 69 74 65 ! lb "VALUE" ite
1150: 6d 29 29 29 20 3b 3b 20 28 6e 75 6d 62 65 72 2d m))) ;; (number-
1160: 3e 73 74 72 69 6e 67 20 69 29 29 29 29 0a 09 09 >string i))))...
1170: 28 73 65 74 21 20 69 20 28 2b 20 69 20 31 29 29 (set! i (+ i 1))
1180: 29 0a 09 20 20 20 20 20 20 69 74 65 6d 73 29 0a ).. items).
1190: 20 20 20 20 69 29 29 0a 0a 28 64 65 66 69 6e 65 i))..(define
11a0: 20 28 70 61 64 2d 6c 69 73 74 20 6c 20 6e 29 28 (pad-list l n)(
11b0: 61 70 70 65 6e 64 20 6c 20 28 6d 61 6b 65 2d 6c append l (make-l
11c0: 69 73 74 20 28 2d 20 6e 20 28 6c 65 6e 67 74 68 ist (- n (length
11d0: 20 6c 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 l)))))..(define
11e0: 20 28 63 6f 6c 6f 72 73 2d 73 69 6d 69 6c 61 72 (colors-similar
11f0: 3f 20 63 6f 6c 6f 72 31 20 63 6f 6c 6f 72 32 29 ? color1 color2)
1200: 0a 20 20 28 6c 65 74 2a 20 28 28 63 31 20 28 6d . (let* ((c1 (m
1210: 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ap string->numbe
1220: 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
1230: 63 6f 6c 6f 72 31 29 29 29 0a 09 20 28 63 32 20 color1))).. (c2
1240: 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d (map string->num
1250: 62 65 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ber (string-spli
1260: 74 20 63 6f 6c 6f 72 32 29 29 29 0a 09 20 28 64 t color2))).. (d
1270: 65 6c 74 61 20 28 6d 61 70 20 28 6c 61 6d 62 64 elta (map (lambd
1280: 61 20 28 61 20 62 29 28 61 62 73 20 28 2d 20 61 a (a b)(abs (- a
1290: 20 62 29 29 29 20 63 31 20 63 32 29 29 29 0a 20 b))) c1 c2))).
12a0: 20 20 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 (null? (filte
12b0: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 3e 20 r (lambda (x)(>
12c0: 78 20 33 29 29 20 64 65 6c 74 61 29 29 29 29 0a x 3)) delta)))).
12d0: 0a 3b 3b 20 6b 65 79 70 61 74 74 73 3a 20 28 20 .;; keypatts: (
12e0: 28 4b 45 59 31 20 22 61 62 63 25 64 65 66 22 29 (KEY1 "abc%def")
12f0: 28 4b 45 59 32 20 22 25 22 29 20 29 0a 28 64 65 (KEY2 "%") ).(de
1300: 66 69 6e 65 20 28 75 70 64 61 74 65 2d 72 75 6e fine (update-run
1310: 64 61 74 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 dat runnamepatt
1320: 6e 75 6d 72 75 6e 73 20 74 65 73 74 6e 61 6d 65 numruns testname
1330: 70 61 74 74 20 6b 65 79 70 61 74 74 73 29 0a 20 patt keypatts).
1340: 20 28 6c 65 74 20 28 28 6d 6f 64 74 69 6d 65 20 (let ((modtime
1350: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c (fil
1360: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
1370: 69 6d 65 20 2a 64 62 2d 66 69 6c 65 2d 70 61 74 ime *db-file-pat
1380: 68 2a 29 29 0a 09 28 72 65 66 65 72 65 6e 63 65 h*))..(reference
1390: 64 2d 72 75 6e 2d 69 64 73 20 27 28 29 29 29 0a d-run-ids '())).
13a0: 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 (if (or (and
13b0: 20 28 3e 20 6d 6f 64 74 69 6d 65 20 2a 6c 61 73 (> modtime *las
13c0: 74 2d 64 62 2d 75 70 64 61 74 65 2d 74 69 6d 65 t-db-update-time
13d0: 2a 29 0a 09 09 20 28 3e 20 28 63 75 72 72 65 6e *)... (> (curren
13e0: 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 2a 6c 61 t-seconds)(+ *la
13f0: 73 74 2d 64 62 2d 75 70 64 61 74 65 2d 74 69 6d st-db-update-tim
1400: 65 2a 20 35 29 29 29 0a 09 20 20 20 20 28 3e 20 e* 5))).. (>
1410: 2a 64 65 6c 61 79 65 64 2d 75 70 64 61 74 65 2a *delayed-update*
1420: 20 30 29 29 0a 09 3b 3b 0a 09 3b 3b 20 52 75 6e 0))..;;..;; Run
1430: 20 74 68 69 73 20 73 74 75 66 66 20 6f 6e 6c 79 this stuff only
1440: 20 77 68 65 6e 20 74 68 65 20 6d 65 67 61 74 65 when the megate
1450: 73 74 2e 64 62 20 66 69 6c 65 20 68 61 73 20 63 st.db file has c
1460: 68 61 6e 67 65 64 0a 09 3b 3b 0a 09 28 6c 65 74 hanged..;;..(let
1470: 20 28 28 66 75 6c 6c 2d 72 75 6e 20 28 3e 20 28 ((full-run (> (
1480: 72 61 6e 64 6f 6d 20 31 30 30 29 20 37 35 29 29 random 100) 75))
1490: 29 20 3b 3b 20 32 35 25 20 6f 66 20 74 68 65 20 ) ;; 25% of the
14a0: 74 69 6d 65 20 64 6f 20 61 20 66 75 6c 6c 20 72 time do a full r
14b0: 65 66 72 65 73 68 0a 09 20 20 28 64 65 62 75 67 efresh.. (debug
14c0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 75 :print-info 4 "u
14d0: 70 64 61 74 65 2d 72 75 6e 64 61 74 20 72 75 6e pdate-rundat run
14e0: 6e 61 6d 65 70 61 74 74 3a 20 22 20 72 75 6e 6e namepatt: " runn
14f0: 61 6d 65 70 61 74 74 20 22 20 6e 75 6d 72 75 6e amepatt " numrun
1500: 73 3a 20 22 20 6e 75 6d 72 75 6e 73 20 22 20 74 s: " numruns " t
1510: 65 73 74 6e 61 6d 65 70 61 74 74 3a 20 22 20 74 estnamepatt: " t
1520: 65 73 74 6e 61 6d 65 70 61 74 74 20 22 20 6b 65 estnamepatt " ke
1530: 79 70 61 74 74 73 3a 20 22 20 6b 65 79 70 61 74 ypatts: " keypat
1540: 74 73 29 0a 09 20 20 28 73 65 74 21 20 2a 70 6c ts).. (set! *pl
1550: 65 61 73 65 2d 75 70 64 61 74 65 2d 62 75 74 74 ease-update-butt
1560: 6f 6e 73 2a 20 23 74 29 0a 09 20 20 28 73 65 74 ons* #t).. (set
1570: 21 20 2a 6c 61 73 74 2d 64 62 2d 75 70 64 61 74 ! *last-db-updat
1580: 65 2d 74 69 6d 65 2a 20 6d 6f 64 74 69 6d 65 29 e-time* modtime)
1590: 0a 09 20 20 28 73 65 74 21 20 2a 64 65 6c 61 79 .. (set! *delay
15a0: 65 64 2d 75 70 64 61 74 65 2a 20 28 2d 20 2a 64 ed-update* (- *d
15b0: 65 6c 61 79 65 64 2d 75 70 64 61 74 65 2a 20 31 elayed-update* 1
15c0: 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 61 6c )).. (let* ((al
15d0: 6c 72 75 6e 73 20 20 20 20 20 28 63 64 62 3a 72 lruns (cdb:r
15e0: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 emote-run db:get
15f0: 2d 72 75 6e 73 20 23 66 20 72 75 6e 6e 61 6d 65 -runs #f runname
1600: 70 61 74 74 20 6e 75 6d 72 75 6e 73 20 3b 3b 20 patt numruns ;;
1610: 28 2b 20 6e 75 6d 72 75 6e 73 20 31 29 20 3b 3b (+ numruns 1) ;;
1620: 20 28 2f 20 6e 75 6d 72 75 6e 73 20 32 29 29 0a (/ numruns 2)).
1630: 09 09 09 09 09 20 20 20 2a 73 74 61 72 74 2d 72 ..... *start-r
1640: 75 6e 2d 6f 66 66 73 65 74 2a 20 6b 65 79 70 61 un-offset* keypa
1650: 74 74 73 29 29 0a 09 09 20 28 68 65 61 64 65 72 tts))... (header
1660: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 68 65 (db:get-he
1670: 61 64 65 72 20 61 6c 6c 72 75 6e 73 29 29 0a 09 ader allruns))..
1680: 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 28 . (runs (
1690: 64 62 3a 67 65 74 2d 72 6f 77 73 20 20 20 61 6c db:get-rows al
16a0: 6c 72 75 6e 73 29 29 0a 09 09 20 28 72 65 73 75 lruns))... (resu
16b0: 6c 74 20 20 20 20 20 20 27 28 29 29 0a 09 09 20 lt '())...
16c0: 28 6d 61 78 74 65 73 74 73 20 20 20 20 30 29 0a (maxtests 0).
16d0: 09 09 20 28 73 74 61 74 65 73 20 20 20 20 20 20 .. (states
16e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
16f0: 20 2a 73 74 61 74 65 2d 69 67 6e 6f 72 65 2d 68 *state-ignore-h
1700: 61 73 68 2a 29 29 0a 09 09 20 28 73 74 61 74 75 ash*))... (statu
1710: 73 65 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 ses (hash-tab
1720: 6c 65 2d 6b 65 79 73 20 2a 73 74 61 74 75 73 2d le-keys *status-
1730: 69 67 6e 6f 72 65 2d 68 61 73 68 2a 29 29 29 0a ignore-hash*))).
1740: 09 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d . ;; (thread-
1750: 73 6c 65 65 70 21 20 30 2e 31 29 20 3b 3b 20 67 sleep! 0.1) ;; g
1760: 69 76 65 20 73 6f 6d 65 20 74 69 6d 65 20 74 6f ive some time to
1770: 20 6f 74 68 65 72 20 74 68 72 65 61 64 73 0a 09 other threads..
1780: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1790: 20 36 20 22 75 70 64 61 74 65 2d 72 75 6e 64 61 6 "update-runda
17a0: 74 2c 20 67 6f 74 20 22 20 28 6c 65 6e 67 74 68 t, got " (length
17b0: 20 72 75 6e 73 29 20 22 20 72 75 6e 73 22 29 0a runs) " runs").
17c0: 09 20 20 20 20 28 69 66 20 28 3e 20 28 2b 20 2a . (if (> (+ *
17d0: 6c 61 73 74 2d 75 70 64 61 74 65 2a 20 33 30 30 last-update* 300
17e0: 29 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e ) (current-secon
17f0: 64 73 29 29 20 3b 3b 20 65 76 65 72 79 20 66 69 ds)) ;; every fi
1800: 76 65 20 6d 69 6e 75 74 65 73 0a 09 09 28 62 65 ve minutes...(be
1810: 67 69 6e 0a 09 09 20 20 28 73 65 74 21 20 2a 6c gin... (set! *l
1820: 61 73 74 2d 75 70 64 61 74 65 2a 20 28 63 75 72 ast-update* (cur
1830: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
1840: 09 20 20 28 73 65 74 21 20 2a 74 6f 74 2d 72 75 . (set! *tot-ru
1850: 6e 2d 63 6f 75 6e 74 2a 20 28 6c 65 6e 67 74 68 n-count* (length
1860: 20 72 75 6e 73 29 29 29 29 0a 09 20 20 20 20 3b runs)))).. ;
1870: 3b 20 0a 09 20 20 20 20 3b 3b 20 74 72 69 6d 20 ; .. ;; trim
1880: 72 75 6e 73 20 74 6f 20 6f 6e 6c 79 20 74 68 6f runs to only tho
1890: 73 65 20 74 68 61 74 20 61 72 65 20 63 68 61 6e se that are chan
18a0: 67 69 6e 67 20 6f 66 74 65 6e 20 68 65 72 65 0a ging often here.
18b0: 0a 09 20 20 20 20 3b 3b 20 0a 09 20 20 20 20 28 .. ;; .. (
18c0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
18d0: 20 28 72 75 6e 29 0a 09 09 09 28 6c 65 74 2a 20 (run)....(let*
18e0: 28 28 72 75 6e 2d 69 64 20 20 20 28 64 62 3a 67 ((run-id (db:g
18f0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
1900: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
1910: 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 d")).... (
1920: 74 65 73 74 73 20 20 20 20 28 6c 65 74 20 28 28 tests (let ((
1930: 74 73 74 73 20 28 63 64 62 3a 72 65 6d 6f 74 65 tsts (cdb:remote
1940: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 -run db:get-test
1950: 73 2d 66 6f 72 2d 72 75 6e 20 23 66 20 72 75 6e s-for-run #f run
1960: 2d 69 64 20 74 65 73 74 6e 61 6d 65 70 61 74 74 -id testnamepatt
1970: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 states statuses
1980: 29 29 29 0a 09 09 09 09 09 20 20 20 28 69 66 20 )))...... (if
1990: 2a 74 65 73 74 73 2d 73 6f 72 74 2d 72 65 76 65 *tests-sort-reve
19a0: 72 73 65 2a 20 28 72 65 76 65 72 73 65 20 74 73 rse* (reverse ts
19b0: 74 73 29 20 74 73 74 73 29 29 29 0a 09 09 09 20 ts) tsts)))....
19c0: 20 20 20 20 20 20 28 6b 65 79 2d 76 61 6c 73 20 (key-vals
19d0: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
19e0: 64 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 db:get-key-vals
19f0: 23 66 20 72 75 6e 2d 69 64 29 29 29 0a 09 09 09 #f run-id)))....
1a00: 20 20 3b 3b 20 4e 6f 74 20 73 75 72 65 20 74 68 ;; Not sure th
1a10: 69 73 20 69 73 20 6e 65 65 64 65 64 3f 0a 09 09 is is needed?...
1a20: 09 20 20 28 73 65 74 21 20 72 65 66 65 72 65 6e . (set! referen
1a30: 63 65 64 2d 72 75 6e 2d 69 64 73 20 28 63 6f 6e ced-run-ids (con
1a40: 73 20 72 75 6e 2d 69 64 20 72 65 66 65 72 65 6e s run-id referen
1a50: 63 65 64 2d 72 75 6e 2d 69 64 73 29 29 0a 09 09 ced-run-ids))...
1a60: 09 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 . (if (> (lengt
1a70: 68 20 74 65 73 74 73 29 20 6d 61 78 74 65 73 74 h tests) maxtest
1a80: 73 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 s).... (set
1a90: 21 20 6d 61 78 74 65 73 74 73 20 28 6c 65 6e 67 ! maxtests (leng
1aa0: 74 68 20 74 65 73 74 73 29 29 29 0a 09 09 09 20 th tests)))....
1ab0: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 2a 68 (if (or (not *h
1ac0: 69 64 65 2d 65 6d 70 74 79 2d 72 75 6e 73 2a 29 ide-empty-runs*)
1ad0: 20 3b 3b 20 74 68 69 73 20 72 65 64 75 63 65 73 ;; this reduces
1ae0: 20 74 68 65 20 64 61 74 61 20 62 75 72 64 65 6e the data burden
1af0: 20 77 68 65 6e 20 73 65 74 0a 09 09 09 09 20 20 when set.....
1b00: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
1b10: 73 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 6c s))).... (l
1b20: 65 74 20 28 28 64 73 74 72 75 63 74 20 28 76 65 et ((dstruct (ve
1b30: 63 74 6f 72 20 72 75 6e 20 74 65 73 74 73 20 6b ctor run tests k
1b40: 65 79 2d 76 61 6c 73 29 29 29 0a 09 09 09 09 3b ey-vals))).....;
1b50: 3b 0a 09 09 09 09 3b 3b 20 63 6f 6d 70 61 72 65 ;.....;; compare
1b60: 20 74 68 65 20 74 65 73 74 73 20 77 69 74 68 20 the tests with
1b70: 74 68 65 20 74 65 73 74 73 20 69 6e 20 2a 61 6c the tests in *al
1b80: 6c 72 75 6e 73 2d 62 79 2d 69 64 2a 20 73 61 6d lruns-by-id* sam
1b90: 65 20 72 75 6e 2d 69 64 20 0a 09 09 09 09 3b 3b e run-id .....;;
1ba0: 20 69 66 20 64 69 66 66 65 72 65 6e 74 20 74 68 if different th
1bb0: 65 6e 20 69 6e 63 72 65 6d 65 6e 74 20 76 61 6c en increment val
1bc0: 75 65 20 69 6e 20 2a 72 75 6e 63 68 61 6e 67 65 ue in *runchange
1bd0: 72 61 74 65 2a 0a 09 09 09 09 3b 3b 0a 09 09 09 rate*.....;;....
1be0: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
1bf0: 21 20 2a 61 6c 6c 72 75 6e 73 2d 62 79 2d 69 64 ! *allruns-by-id
1c00: 2a 20 72 75 6e 2d 69 64 20 64 73 74 72 75 63 74 * run-id dstruct
1c10: 29 0a 09 09 09 09 28 73 65 74 21 20 72 65 73 75 ).....(set! resu
1c20: 6c 74 20 28 63 6f 6e 73 20 64 73 74 72 75 63 74 lt (cons dstruct
1c30: 20 72 65 73 75 6c 74 29 29 29 29 29 29 0a 09 09 result))))))...
1c40: 20 20 20 20 20 20 72 75 6e 73 29 0a 09 20 20 20 runs)..
1c50: 20 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b .. ;;.. ;
1c60: 3b 20 69 66 20 66 75 6c 6c 2d 72 75 6e 20 75 73 ; if full-run us
1c70: 65 20 72 65 66 65 72 65 6e 63 65 64 2d 72 75 6e e referenced-run
1c80: 2d 69 64 73 20 74 6f 20 64 65 6c 65 74 65 20 64 -ids to delete d
1c90: 61 74 61 20 69 6e 20 2a 61 6c 6c 2d 72 75 6e 73 ata in *all-runs
1ca0: 2d 62 79 2d 69 64 2a 20 61 6e 64 20 2a 72 75 6e -by-id* and *run
1cb0: 63 68 61 6e 67 65 72 61 74 65 2a 0a 09 20 20 20 changerate*..
1cc0: 20 3b 3b 0a 0a 09 20 20 20 20 28 73 65 74 21 20 ;;... (set!
1cd0: 2a 68 65 61 64 65 72 2a 20 20 68 65 61 64 65 72 *header* header
1ce0: 29 0a 09 20 20 20 20 28 73 65 74 21 20 2a 61 6c ).. (set! *al
1cf0: 6c 72 75 6e 73 2a 20 72 65 73 75 6c 74 29 0a 09 lruns* result)..
1d00: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1d10: 20 36 20 22 2a 61 6c 6c 72 75 6e 73 2a 20 68 61 6 "*allruns* ha
1d20: 73 20 22 20 28 6c 65 6e 67 74 68 20 2a 61 6c 6c s " (length *all
1d30: 72 75 6e 73 2a 29 20 22 20 72 75 6e 73 22 29 0a runs*) " runs").
1d40: 09 20 20 20 20 3b 3b 20 28 73 65 74 21 20 2a 74 . ;; (set! *t
1d50: 6f 74 2d 72 75 6e 2d 63 6f 75 6e 74 2a 20 28 2b ot-run-count* (+
1d60: 20 31 20 28 6c 65 6e 67 74 68 20 2a 61 6c 6c 72 1 (length *allr
1d70: 75 6e 73 2a 29 29 29 0a 09 20 20 20 20 6d 61 78 uns*))).. max
1d80: 74 65 73 74 73 29 29 0a 09 3b 3b 20 0a 09 3b 3b tests))..;; ..;;
1d90: 20 52 75 6e 20 74 68 69 73 20 69 66 20 74 68 65 Run this if the
1da0: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 66 69 6c megatest.db fil
1db0: 65 20 64 69 64 20 6e 6f 74 20 67 65 74 20 74 6f e did not get to
1dc0: 75 63 68 65 64 0a 09 3b 3b 0a 09 28 62 65 67 69 uched..;;..(begi
1dd0: 6e 0a 09 20 20 0a 09 20 20 2a 6e 75 6d 2d 74 65 n.. .. *num-te
1de0: 73 74 73 2a 29 29 29 29 20 3b 3b 20 46 49 58 4d sts*)))) ;; FIXM
1df0: 45 2c 20 6e 61 75 67 68 74 79 20 63 6f 64 69 6e E, naughty codin
1e00: 67 20 65 68 3f 0a 0a 28 64 65 66 69 6e 65 20 2a g eh?..(define *
1e10: 63 6f 6c 6c 61 70 73 65 64 2a 20 28 6d 61 6b 65 collapsed* (make
1e20: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 3b 20 -hash-table)).;
1e30: 28 64 65 66 69 6e 65 20 2a 72 6f 77 2d 6c 6f 6f (define *row-loo
1e40: 6b 75 70 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d kup* (make-hash-
1e50: 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 73 74 6e table)) ;; testn
1e60: 61 6d 65 20 3d 3e 20 28 72 6f 77 6e 75 6d 20 6c ame => (rownum l
1e70: 61 62 6c 65 6f 62 6a 29 0a 0a 28 64 65 66 69 6e ableobj)..(defin
1e80: 65 20 28 74 6f 67 67 6c 65 2d 68 69 64 65 20 6c e (toggle-hide l
1e90: 6e 75 6d 29 20 3b 20 66 75 6c 6c 74 65 73 74 6e num) ; fulltestn
1ea0: 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 62 ame). (let* ((b
1eb0: 74 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 tn (vector-ref (
1ec0: 64 62 6f 61 72 64 3a 75 69 64 61 74 2d 67 65 74 dboard:uidat-get
1ed0: 2d 6c 66 74 63 6f 6c 20 75 69 64 61 74 29 20 6c -lftcol uidat) l
1ee0: 6e 75 6d 29 29 0a 09 20 28 66 75 6c 6c 74 65 73 num)).. (fulltes
1ef0: 74 6e 61 6d 65 20 28 69 75 70 3a 61 74 74 72 69 tname (iup:attri
1f00: 62 75 74 65 20 62 74 6e 20 22 54 49 54 4c 45 22 bute btn "TITLE"
1f10: 29 29 0a 09 20 28 70 61 72 74 73 20 20 20 20 20 )).. (parts
1f20: 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
1f30: 20 66 75 6c 6c 74 65 73 74 6e 61 6d 65 20 22 28 fulltestname "(
1f40: 22 29 29 0a 09 20 28 62 61 73 65 74 65 73 74 6e ")).. (basetestn
1f50: 61 6d 65 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 ame (if (null? p
1f60: 61 72 74 73 29 20 22 22 20 28 63 61 72 20 70 61 arts) "" (car pa
1f70: 72 74 73 29 29 29 29 0a 20 20 20 20 3b 28 70 72 rts)))). ;(pr
1f80: 69 6e 74 20 22 54 6f 67 67 6c 69 6e 67 20 22 20 int "Toggling "
1f90: 62 61 73 65 74 65 73 74 6e 61 6d 65 20 22 20 63 basetestname " c
1fa0: 75 72 72 65 6e 74 6c 79 20 22 20 28 68 61 73 68 urrently " (hash
1fb0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1fc0: 6c 74 20 2a 63 6f 6c 6c 61 70 73 65 64 2a 20 62 lt *collapsed* b
1fd0: 61 73 65 74 65 73 74 6e 61 6d 65 20 23 66 29 29 asetestname #f))
1fe0: 0a 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 . (if (hash-t
1ff0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2000: 20 2a 63 6f 6c 6c 61 70 73 65 64 2a 20 62 61 73 *collapsed* bas
2010: 65 74 65 73 74 6e 61 6d 65 20 23 66 29 0a 09 28 etestname #f)..(
2020: 62 65 67 69 6e 0a 09 20 20 3b 28 69 75 70 3a 61 begin.. ;(iup:a
2030: 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 62 74 ttribute-set! bt
2040: 6e 20 22 46 47 43 4f 4c 4f 52 22 20 22 30 20 30 n "FGCOLOR" "0 0
2050: 20 30 22 29 0a 09 20 20 28 68 61 73 68 2d 74 61 0").. (hash-ta
2060: 62 6c 65 2d 64 65 6c 65 74 65 21 20 2a 63 6f 6c ble-delete! *col
2070: 6c 61 70 73 65 64 2a 20 62 61 73 65 74 65 73 74 lapsed* basetest
2080: 6e 61 6d 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 name))..(begin..
2090: 20 20 3b 28 69 75 70 3a 61 74 74 72 69 62 75 74 ;(iup:attribut
20a0: 65 2d 73 65 74 21 20 62 74 6e 20 22 46 47 43 4f e-set! btn "FGCO
20b0: 4c 4f 52 22 20 22 30 20 31 39 32 20 31 39 32 22 LOR" "0 192 192"
20c0: 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ).. (hash-table
20d0: 2d 73 65 74 21 20 2a 63 6f 6c 6c 61 70 73 65 64 -set! *collapsed
20e0: 2a 20 62 61 73 65 74 65 73 74 6e 61 6d 65 20 23 * basetestname #
20f0: 74 29 29 29 29 29 0a 20 20 0a 28 64 65 66 69 6e t))))). .(defin
2100: 65 20 62 6c 61 6e 6b 2d 6c 69 6e 65 2d 72 78 20 e blank-line-rx
2110: 28 72 65 67 65 78 70 20 22 5e 5c 5c 73 2a 24 22 (regexp "^\\s*$"
2120: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
2130: 2d 69 74 65 6d 2d 6e 61 6d 65 2d 3e 76 65 63 74 -item-name->vect
2140: 6f 72 73 20 6c 73 74 29 0a 20 20 28 6d 61 70 20 ors lst). (map
2150: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 28 6c (lambda (x).. (l
2160: 65 74 20 28 28 73 70 6c 73 74 20 28 73 74 72 69 et ((splst (stri
2170: 6e 67 2d 73 70 6c 69 74 20 78 20 22 28 22 29 29 ng-split x "("))
2180: 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 20 20 .. (res
2190: 28 76 65 63 74 6f 72 20 22 22 20 22 22 29 29 29 (vector "" "")))
21a0: 0a 09 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 .. (vector-set
21b0: 21 20 72 65 73 20 30 20 28 63 61 72 20 73 70 6c ! res 0 (car spl
21c0: 73 74 29 29 0a 09 20 20 20 28 69 66 20 28 3e 20 st)).. (if (>
21d0: 28 6c 65 6e 67 74 68 20 73 70 6c 73 74 29 20 31 (length splst) 1
21e0: 29 0a 09 20 20 20 20 20 20 20 28 76 65 63 74 6f ).. (vecto
21f0: 72 2d 73 65 74 21 20 72 65 73 20 31 20 28 63 61 r-set! res 1 (ca
2200: 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
2210: 28 63 61 64 72 20 73 70 6c 73 74 29 20 22 29 22 (cadr splst) ")"
2220: 29 29 29 29 0a 09 20 20 20 72 65 73 29 29 0a 20 )))).. res)).
2230: 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 28 64 65 lst))..(de
2240: 66 69 6e 65 20 28 63 6f 6c 6c 61 70 73 65 2d 72 fine (collapse-r
2250: 6f 77 73 20 69 6e 6c 73 74 29 0a 20 20 28 6c 65 ows inlst). (le
2260: 74 2a 20 28 28 6e 65 77 6c 73 74 20 28 66 69 6c t* ((newlst (fil
2270: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
2280: 09 09 09 20 20 28 6c 65 74 2a 20 28 28 74 70 61 ... (let* ((tpa
2290: 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d 73 rts (string-s
22a0: 70 6c 69 74 20 78 20 22 28 22 29 29 0a 09 09 09 plit x "("))....
22b0: 09 20 28 62 61 73 65 74 6e 61 6d 65 20 28 69 66 . (basetname (if
22c0: 20 28 6e 75 6c 6c 3f 20 74 70 61 72 74 73 29 20 (null? tparts)
22d0: 78 20 28 63 61 72 20 74 70 61 72 74 73 29 29 29 x (car tparts)))
22e0: 29 0a 09 09 09 09 09 3b 28 70 72 69 6e 74 20 22 )......;(print "
22f0: 78 20 22 20 78 20 22 20 74 70 61 72 74 73 3a 20 x " x " tparts:
2300: 22 20 74 70 61 72 74 73 20 22 20 62 61 73 65 74 " tparts " baset
2310: 6e 61 6d 65 3a 20 22 20 62 61 73 65 74 6e 61 6d name: " basetnam
2320: 65 29 0a 09 09 09 20 20 20 20 28 63 6f 6e 64 0a e).... (cond.
2330: 09 09 09 20 20 20 20 20 28 28 73 74 72 69 6e 67 ... ((string
2340: 2d 6d 61 74 63 68 20 62 6c 61 6e 6b 2d 6c 69 6e -match blank-lin
2350: 65 2d 72 78 20 78 29 20 23 66 29 0a 09 09 09 20 e-rx x) #f)....
2360: 20 20 20 20 28 28 65 71 75 61 6c 3f 20 78 20 62 ((equal? x b
2370: 61 73 65 74 6e 61 6d 65 29 20 23 74 29 0a 09 09 asetname) #t)...
2380: 09 20 20 20 20 20 28 28 68 61 73 68 2d 74 61 62 . ((hash-tab
2390: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
23a0: 63 6f 6c 6c 61 70 73 65 64 2a 20 62 61 73 65 74 collapsed* baset
23b0: 6e 61 6d 65 20 23 66 29 20 0a 09 09 09 09 09 3b name #f) ......;
23c0: 28 70 72 69 6e 74 20 22 52 65 6d 6f 76 69 6e 67 (print "Removing
23d0: 20 22 20 62 61 73 65 74 6e 61 6d 65 20 22 20 66 " basetname " f
23e0: 72 6f 6d 20 69 74 65 6d 73 22 29 0a 09 09 09 20 rom items")....
23f0: 20 20 20 20 20 23 66 29 0a 09 09 09 20 20 20 20 #f)....
2400: 20 28 65 6c 73 65 20 23 74 29 29 29 29 0a 09 09 (else #t))))...
2410: 09 69 6e 6c 73 74 29 29 0a 09 20 28 76 6c 73 74 .inlst)).. (vlst
2420: 20 20 28 72 75 6e 2d 69 74 65 6d 2d 6e 61 6d 65 (run-item-name
2430: 2d 3e 76 65 63 74 6f 72 73 20 6e 65 77 6c 73 74 ->vectors newlst
2440: 29 29 0a 09 20 3b 3b 20 73 6f 72 74 20 62 79 20 )).. ;; sort by
2450: 73 65 63 6f 6e 64 20 66 69 65 6c 64 0a 09 20 28 second field.. (
2460: 76 6c 73 74 2d 73 31 20 28 73 6f 72 74 20 76 6c vlst-s1 (sort vl
2470: 73 74 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 st (lambda (a b)
2480: 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 .... (let
2490: 28 28 61 73 74 72 20 28 76 65 63 74 6f 72 2d 72 ((astr (vector-r
24a0: 65 66 20 61 20 31 29 29 0a 09 09 09 09 20 20 20 ef a 1)).....
24b0: 20 20 28 62 73 74 72 20 28 76 65 63 74 6f 72 2d (bstr (vector-
24c0: 72 65 66 20 62 20 31 29 29 29 0a 09 09 09 09 20 ref b 1))).....
24d0: 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 61 73 (if (string=? as
24e0: 74 72 20 22 22 29 20 23 66 20 23 74 29 29 29 29 tr "") #f #t))))
24f0: 29 0a 09 09 09 3b 3b 20 28 3e 3d 20 28 73 74 72 )....;; (>= (str
2500: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 76 65 63 74 ing-length (vect
2510: 6f 72 2d 72 65 66 20 61 20 31 29 29 28 73 74 72 or-ref a 1))(str
2520: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 76 65 63 74 ing-length (vect
2530: 6f 72 2d 72 65 66 20 62 20 31 29 29 29 29 29 29 or-ref b 1))))))
2540: 0a 09 20 28 76 6c 73 74 2d 73 32 20 28 73 6f 72 .. (vlst-s2 (sor
2550: 74 20 76 6c 73 74 2d 73 31 20 28 6c 61 6d 62 64 t vlst-s1 (lambd
2560: 61 20 28 61 20 62 29 0a 09 09 09 20 20 20 09 20 a (a b).... .
2570: 20 28 73 74 72 69 6e 67 3e 3d 20 28 76 65 63 74 (string>= (vect
2580: 6f 72 2d 72 65 66 20 61 20 30 29 28 76 65 63 74 or-ref a 0)(vect
2590: 6f 72 2d 72 65 66 20 62 20 30 29 29 29 29 29 29 or-ref b 0))))))
25a0: 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
25b0: 61 20 28 78 29 0a 09 20 20 20 28 69 66 20 28 65 a (x).. (if (e
25c0: 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 qual? (vector-re
25d0: 66 20 78 20 31 29 20 22 22 29 0a 09 20 20 20 20 f x 1) "")..
25e0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (vector-ref x
25f0: 20 30 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 0).. (con
2600: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 c (vector-ref x
2610: 30 29 20 22 28 22 20 28 76 65 63 74 6f 72 2d 72 0) "(" (vector-r
2620: 65 66 20 78 20 31 29 20 22 29 22 29 29 29 0a 09 ef x 1) ")")))..
2630: 20 76 6c 73 74 2d 73 32 29 29 29 0a 20 20 20 20 vlst-s2))).
2640: 0a 28 64 65 66 69 6e 65 20 28 75 70 64 61 74 65 .(define (update
2650: 2d 6c 61 62 65 6c 73 20 75 69 64 61 74 29 0a 20 -labels uidat).
2660: 20 28 6c 65 74 2a 20 28 28 72 6f 77 6e 20 20 20 (let* ((rown
2670: 20 30 29 0a 09 20 28 6b 65 79 63 6f 6c 20 20 28 0).. (keycol (
2680: 64 62 6f 61 72 64 3a 75 69 64 61 74 2d 67 65 74 dboard:uidat-get
2690: 2d 6b 65 79 63 6f 6c 20 75 69 64 61 74 29 29 0a -keycol uidat)).
26a0: 09 20 28 6c 66 74 63 6f 6c 20 20 28 64 62 6f 61 . (lftcol (dboa
26b0: 72 64 3a 75 69 64 61 74 2d 67 65 74 2d 6c 66 74 rd:uidat-get-lft
26c0: 63 6f 6c 20 75 69 64 61 74 29 29 0a 09 20 28 6e col uidat)).. (n
26d0: 75 6d 63 6f 6c 73 20 28 76 65 63 74 6f 72 2d 6c umcols (vector-l
26e0: 65 6e 67 74 68 20 6c 66 74 63 6f 6c 29 29 0a 09 ength lftcol))..
26f0: 20 28 6d 61 78 6e 20 20 20 20 28 2d 20 6e 75 6d (maxn (- num
2700: 63 6f 6c 73 20 31 29 29 0a 09 20 28 61 6c 6c 76 cols 1)).. (allv
2710: 61 6c 73 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 als (make-vector
2720: 20 6e 75 6d 63 6f 6c 73 20 22 22 29 29 29 0a 20 numcols ""))).
2730: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
2740: 6d 62 64 61 20 28 6e 61 6d 65 29 0a 09 09 28 69 mbda (name)...(i
2750: 66 20 28 3c 3d 20 72 6f 77 6e 20 6d 61 78 6e 29 f (<= rown maxn)
2760: 0a 09 09 20 20 20 20 28 76 65 63 74 6f 72 2d 73 ... (vector-s
2770: 65 74 21 20 61 6c 6c 76 61 6c 73 20 72 6f 77 6e et! allvals rown
2780: 20 6e 61 6d 65 29 29 20 3b 29 0a 09 09 28 73 65 name)) ;)...(se
2790: 74 21 20 72 6f 77 6e 20 28 2b 20 31 20 72 6f 77 t! rown (+ 1 row
27a0: 6e 29 29 29 0a 09 20 20 20 20 20 20 2a 61 6c 6c n))).. *all
27b0: 74 65 73 74 6e 61 6d 65 6c 73 74 2a 29 0a 20 20 testnamelst*).
27c0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 20 (let loop ((i
27d0: 30 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 0)). (let*
27e0: 28 28 6c 62 6c 20 20 20 20 28 76 65 63 74 6f 72 ((lbl (vector
27f0: 2d 72 65 66 20 6c 66 74 63 6f 6c 20 69 29 29 0a -ref lftcol i)).
2800: 09 20 20 20 20 20 28 6b 65 79 76 61 6c 20 28 76 . (keyval (v
2810: 65 63 74 6f 72 2d 72 65 66 20 6b 65 79 63 6f 6c ector-ref keycol
2820: 20 69 29 29 0a 09 20 20 20 20 20 28 6f 6c 64 76 i)).. (oldv
2830: 61 6c 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 al (iup:attribut
2840: 65 20 6c 62 6c 20 22 54 49 54 4c 45 22 29 29 0a e lbl "TITLE")).
2850: 09 20 20 20 20 20 28 6e 65 77 76 61 6c 20 28 76 . (newval (v
2860: 65 63 74 6f 72 2d 72 65 66 20 61 6c 6c 76 61 6c ector-ref allval
2870: 73 20 69 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 s i)))..(if (not
2880: 20 28 65 71 75 61 6c 3f 20 6f 6c 64 76 61 6c 20 (equal? oldval
2890: 6e 65 77 76 61 6c 29 29 0a 09 20 20 20 20 28 6c newval)).. (l
28a0: 65 74 20 28 28 6d 75 6e 67 65 64 2d 76 61 6c 20 et ((munged-val
28b0: 28 6c 65 74 20 28 28 70 61 72 74 73 20 28 73 74 (let ((parts (st
28c0: 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 76 61 ring-split newva
28d0: 6c 20 22 28 22 29 29 29 0a 09 09 09 09 28 69 66 l "("))).....(if
28e0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 61 72 74 (> (length part
28f0: 73 29 20 31 29 28 63 6f 6e 63 20 22 20 20 22 20 s) 1)(conc " "
2900: 28 63 61 72 20 28 73 74 72 69 6e 67 2d 73 70 6c (car (string-spl
2910: 69 74 20 28 63 61 64 72 20 70 61 72 74 73 29 20 it (cadr parts)
2920: 22 29 22 29 29 29 20 6e 65 77 76 61 6c 29 29 29 ")"))) newval)))
2930: 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 ).. (vector
2940: 2d 73 65 74 21 20 6b 65 79 63 6f 6c 20 69 20 6e -set! keycol i n
2950: 65 77 76 61 6c 29 0a 09 20 20 20 20 20 20 28 69 ewval).. (i
2960: 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 up:attribute-set
2970: 21 20 6c 62 6c 20 22 54 49 54 4c 45 22 20 6d 75 ! lbl "TITLE" mu
2980: 6e 67 65 64 2d 76 61 6c 29 29 29 0a 09 28 69 75 nged-val)))..(iu
2990: 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 21 p:attribute-set!
29a0: 20 6c 62 6c 20 22 46 47 43 4f 4c 4f 52 22 20 28 lbl "FGCOLOR" (
29b0: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
29c0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6c 6c ef/default *coll
29d0: 61 70 73 65 64 2a 20 6e 65 77 76 61 6c 20 23 66 apsed* newval #f
29e0: 29 20 22 30 20 31 31 32 20 31 31 32 22 20 22 30 ) "0 112 112" "0
29f0: 20 30 20 30 22 29 29 0a 09 28 69 66 20 28 3c 20 0 0"))..(if (<
2a00: 69 20 6d 61 78 6e 29 0a 09 20 20 20 20 28 6c 6f i maxn).. (lo
2a10: 6f 70 20 28 2b 20 69 20 31 29 29 29 29 29 29 29 op (+ i 1)))))))
2a20: 0a 0a 28 64 65 66 69 6e 65 20 28 75 70 64 61 74 ..(define (updat
2a30: 65 2d 62 75 74 74 6f 6e 73 20 75 69 64 61 74 20 e-buttons uidat
2a40: 6e 75 6d 72 75 6e 73 20 6e 75 6d 74 65 73 74 73 numruns numtests
2a50: 29 0a 20 20 28 69 66 20 2a 70 6c 65 61 73 65 2d ). (if *please-
2a60: 75 70 64 61 74 65 2d 62 75 74 74 6f 6e 73 2a 0a update-buttons*.
2a70: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 (let* ((ru
2a80: 6e 73 20 20 20 20 20 20 20 20 28 69 66 20 28 3e ns (if (>
2a90: 20 28 6c 65 6e 67 74 68 20 2a 61 6c 6c 72 75 6e (length *allrun
2aa0: 73 2a 29 20 6e 75 6d 72 75 6e 73 29 0a 09 09 09 s*) numruns)....
2ab0: 20 20 20 20 20 20 28 74 61 6b 65 2d 72 69 67 68 (take-righ
2ac0: 74 20 2a 61 6c 6c 72 75 6e 73 2a 20 6e 75 6d 72 t *allruns* numr
2ad0: 75 6e 73 29 0a 09 09 09 20 20 20 20 20 20 28 70 uns).... (p
2ae0: 61 64 2d 6c 69 73 74 20 2a 61 6c 6c 72 75 6e 73 ad-list *allruns
2af0: 2a 20 6e 75 6d 72 75 6e 73 29 29 29 0a 09 20 20 * numruns)))..
2b00: 20 20 20 28 6c 66 74 63 6f 6c 20 20 20 20 20 20 (lftcol
2b10: 28 64 62 6f 61 72 64 3a 75 69 64 61 74 2d 67 65 (dboard:uidat-ge
2b20: 74 2d 6c 66 74 63 6f 6c 20 75 69 64 61 74 29 29 t-lftcol uidat))
2b30: 0a 09 20 20 20 20 20 28 74 61 62 6c 65 68 65 61 .. (tablehea
2b40: 64 65 72 20 28 64 62 6f 61 72 64 3a 75 69 64 61 der (dboard:uida
2b50: 74 2d 67 65 74 2d 68 65 61 64 65 72 20 75 69 64 t-get-header uid
2b60: 61 74 29 29 0a 09 20 20 20 20 20 28 74 61 62 6c at)).. (tabl
2b70: 65 20 20 20 20 20 20 20 28 64 62 6f 61 72 64 3a e (dboard:
2b80: 75 69 64 61 74 2d 67 65 74 2d 72 75 6e 73 76 65 uidat-get-runsve
2b90: 63 20 75 69 64 61 74 29 29 0a 09 20 20 20 20 20 c uidat))..
2ba0: 28 63 6f 6c 6e 20 20 20 20 20 20 20 20 30 29 29 (coln 0))
2bb0: 0a 09 28 73 65 74 21 20 2a 70 6c 65 61 73 65 2d ..(set! *please-
2bc0: 75 70 64 61 74 65 2d 62 75 74 74 6f 6e 73 2a 20 update-buttons*
2bd0: 23 66 29 0a 09 28 73 65 74 21 20 2a 61 6c 6c 74 #f)..(set! *allt
2be0: 65 73 74 6e 61 6d 65 6c 73 74 2a 20 27 28 29 29 estnamelst* '())
2bf0: 0a 09 3b 3b 20 63 72 65 61 74 65 20 61 20 63 6f ..;; create a co
2c00: 6e 63 69 73 65 20 6c 69 73 74 20 6f 66 20 74 65 ncise list of te
2c10: 73 74 20 6e 61 6d 65 73 0a 09 28 66 6f 72 2d 65 st names..(for-e
2c20: 61 63 68 0a 09 20 28 6c 61 6d 62 64 61 20 28 72 ach.. (lambda (r
2c30: 75 6e 64 61 74 29 0a 09 20 20 20 28 69 66 20 28 undat).. (if (
2c40: 76 65 63 74 6f 72 3f 20 72 75 6e 64 61 74 29 0a vector? rundat).
2c50: 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
2c60: 74 65 73 74 64 61 74 20 20 20 28 76 65 63 74 6f testdat (vecto
2c70: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
2c80: 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 6e 61 ... (testna
2c90: 6d 65 73 20 28 6d 61 70 20 74 65 73 74 3a 74 65 mes (map test:te
2ca0: 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 6d 65 20 st-get-fullname
2cb0: 74 65 73 74 64 61 74 29 29 29 0a 09 09 20 28 69 testdat)))... (i
2cc0: 66 20 28 6e 6f 74 20 28 61 6e 64 20 2a 68 69 64 f (not (and *hid
2cd0: 65 2d 65 6d 70 74 79 2d 72 75 6e 73 2a 0a 09 09 e-empty-runs*...
2ce0: 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 74 . (null? t
2cf0: 65 73 74 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 estnames)))...
2d00: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
2d10: 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a mbda (testname).
2d20: 09 09 09 09 20 28 69 66 20 28 6e 6f 74 20 28 6d .... (if (not (m
2d30: 65 6d 62 65 72 20 74 65 73 74 6e 61 6d 65 20 2a ember testname *
2d40: 61 6c 6c 74 65 73 74 6e 61 6d 65 6c 73 74 2a 29 alltestnamelst*)
2d50: 29 0a 09 09 09 09 20 20 20 20 20 28 62 65 67 69 )..... (begi
2d60: 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 73 65 n..... (se
2d70: 74 21 20 2a 61 6c 6c 74 65 73 74 6e 61 6d 65 6c t! *alltestnamel
2d80: 73 74 2a 20 28 61 70 70 65 6e 64 20 2a 61 6c 6c st* (append *all
2d90: 74 65 73 74 6e 61 6d 65 6c 73 74 2a 20 28 6c 69 testnamelst* (li
2da0: 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 29 29 st testname)))))
2db0: 29 0a 09 09 09 20 20 20 20 20 20 20 74 65 73 74 ).... test
2dc0: 6e 61 6d 65 73 29 29 29 29 29 0a 09 20 72 75 6e names))))).. run
2dd0: 73 29 0a 0a 09 28 73 65 74 21 20 2a 61 6c 6c 74 s)...(set! *allt
2de0: 65 73 74 6e 61 6d 65 6c 73 74 2a 20 28 63 6f 6c estnamelst* (col
2df0: 6c 61 70 73 65 2d 72 6f 77 73 20 2a 61 6c 6c 74 lapse-rows *allt
2e00: 65 73 74 6e 61 6d 65 6c 73 74 2a 29 29 20 3b 3b estnamelst*)) ;;
2e10: 3b 20 61 72 67 68 2e 20 70 6c 65 61 73 65 20 63 ; argh. please c
2e20: 6c 65 61 6e 20 75 70 20 74 68 69 73 20 73 69 6c lean up this sil
2e30: 6c 79 6e 65 73 73 0a 09 28 73 65 74 21 20 2a 61 lyness..(set! *a
2e40: 6c 6c 74 65 73 74 6e 61 6d 65 6c 73 74 2a 20 28 lltestnamelst* (
2e50: 6c 65 74 20 28 28 78 6c 20 28 69 66 20 28 3e 20 let ((xl (if (>
2e60: 28 6c 65 6e 67 74 68 20 2a 61 6c 6c 74 65 73 74 (length *alltest
2e70: 6e 61 6d 65 6c 73 74 2a 29 20 2a 73 74 61 72 74 namelst*) *start
2e80: 2d 74 65 73 74 2d 6f 66 66 73 65 74 2a 29 0a 09 -test-offset*)..
2e90: 09 09 09 09 20 20 20 20 20 28 64 72 6f 70 20 2a .... (drop *
2ea0: 61 6c 6c 74 65 73 74 6e 61 6d 65 6c 73 74 2a 20 alltestnamelst*
2eb0: 2a 73 74 61 72 74 2d 74 65 73 74 2d 6f 66 66 73 *start-test-offs
2ec0: 65 74 2a 29 0a 09 09 09 09 09 20 20 20 20 20 27 et*)...... '
2ed0: 28 29 29 29 29 0a 09 09 09 09 20 28 61 70 70 65 ())))..... (appe
2ee0: 6e 64 20 78 6c 20 28 6d 61 6b 65 2d 6c 69 73 74 nd xl (make-list
2ef0: 20 28 2d 20 2a 6e 75 6d 2d 74 65 73 74 73 2a 20 (- *num-tests*
2f00: 28 6c 65 6e 67 74 68 20 78 6c 29 29 20 22 22 29 (length xl)) "")
2f10: 29 29 29 0a 09 28 75 70 64 61 74 65 2d 6c 61 62 )))..(update-lab
2f20: 65 6c 73 20 75 69 64 61 74 29 0a 09 28 66 6f 72 els uidat)..(for
2f30: 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 64 61 20 -each.. (lambda
2f40: 28 72 75 6e 64 61 74 29 0a 09 20 20 20 28 69 66 (rundat).. (if
2f50: 20 28 6e 6f 74 20 72 75 6e 64 61 74 29 20 3b 3b (not rundat) ;;
2f60: 20 68 61 6e 64 6c 65 20 70 61 64 64 65 64 20 72 handle padded r
2f70: 75 6e 73 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 uns.. ;;
2f80: 20 20 20 20 20 20 20 20 20 3b 3b 20 69 64 20 72 ;; id r
2f90: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 73 un-id testname s
2fa0: 74 61 74 65 20 73 74 61 74 75 73 20 65 76 65 6e tate status even
2fb0: 74 2d 74 69 6d 65 20 68 6f 73 74 20 63 70 75 6c t-time host cpul
2fc0: 6f 61 64 20 64 69 73 6b 66 72 65 65 20 75 6e 61 oad diskfree una
2fd0: 6d 65 20 72 75 6e 64 69 72 20 69 74 65 6d 2d 70 me rundir item-p
2fe0: 61 74 68 20 72 75 6e 2d 64 75 72 61 74 69 6f 6e ath run-duration
2ff0: 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 20 72 .. (set! r
3000: 75 6e 64 61 74 20 28 76 65 63 74 6f 72 20 28 6d undat (vector (m
3010: 61 6b 65 2d 76 65 63 74 6f 72 20 32 30 20 23 66 ake-vector 20 #f
3020: 29 20 27 28 29 20 28 6d 61 70 20 28 6c 61 6d 62 ) '() (map (lamb
3030: 64 61 20 28 78 29 20 22 22 29 20 2a 6b 65 79 73 da (x) "") *keys
3040: 2a 29 29 29 29 3b 3b 20 33 29 29 29 0a 09 20 20 *))));; 3)))..
3050: 20 28 6c 65 74 2a 20 28 28 72 75 6e 20 20 20 20 (let* ((run
3060: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
3070: 6e 64 61 74 20 30 29 29 0a 09 09 20 20 28 74 65 ndat 0))... (te
3080: 73 74 73 64 61 74 20 28 76 65 63 74 6f 72 2d 72 stsdat (vector-r
3090: 65 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 09 ef rundat 1))...
30a0: 20 20 28 6b 65 79 2d 76 61 6c 2d 64 61 74 20 28 (key-val-dat (
30b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
30c0: 74 20 32 29 29 0a 09 09 20 20 28 72 75 6e 2d 69 t 2))... (run-i
30d0: 64 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 d (db:get-valu
30e0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
30f0: 2a 68 65 61 64 65 72 2a 20 22 69 64 22 29 29 0a *header* "id")).
3100: 09 09 20 20 28 6b 65 79 2d 76 61 6c 73 20 28 61 .. (key-vals (a
3110: 70 70 65 6e 64 20 6b 65 79 2d 76 61 6c 2d 64 61 ppend key-val-da
3120: 74 0a 09 09 09 09 20 20 20 20 28 6c 69 73 74 20 t..... (list
3130: 28 6c 65 74 20 28 28 78 20 28 64 62 3a 67 65 74 (let ((x (db:get
3140: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
3150: 20 72 75 6e 20 2a 68 65 61 64 65 72 2a 20 22 72 run *header* "r
3160: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 09 09 09 unname")))......
3170: 20 20 20 20 28 69 66 20 78 20 78 20 22 22 29 29 (if x x ""))
3180: 29 29 29 0a 09 09 20 20 28 72 75 6e 2d 6b 65 79 )))... (run-key
3190: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
31a0: 70 65 72 73 65 20 6b 65 79 2d 76 61 6c 73 20 22 perse key-vals "
31b0: 5c 6e 22 29 29 29 0a 0a 09 20 20 20 20 20 3b 3b \n")))... ;;
31c0: 20 66 69 6c 6c 20 69 6e 20 74 68 65 20 72 75 6e fill in the run
31d0: 20 68 65 61 64 65 72 20 6b 65 79 20 76 61 6c 75 header key valu
31e0: 65 73 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 es.. (let ((
31f0: 72 6f 77 6e 20 20 20 20 20 20 30 29 0a 09 09 20 rown 0)...
3200: 20 20 28 68 65 61 64 65 72 63 6f 6c 20 28 76 65 (headercol (ve
3210: 63 74 6f 72 2d 72 65 66 20 74 61 62 6c 65 68 65 ctor-ref tablehe
3220: 61 64 65 72 20 63 6f 6c 6e 29 29 29 0a 09 20 20 ader coln)))..
3230: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
3240: 6c 61 6d 62 64 61 20 28 6b 76 61 6c 29 0a 09 09 lambda (kval)...
3250: 09 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 62 6c . (let* ((labl
3260: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
3270: 66 20 68 65 61 64 65 72 63 6f 6c 20 72 6f 77 6e f headercol rown
3280: 29 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 ))).... (if
3290: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 6b 76 61 (not (equal? kva
32a0: 6c 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 l (iup:attribute
32b0: 20 6c 61 62 6c 20 22 54 49 54 4c 45 22 29 29 29 labl "TITLE")))
32c0: 0a 09 09 09 09 20 28 69 75 70 3a 61 74 74 72 69 ..... (iup:attri
32d0: 62 75 74 65 2d 73 65 74 21 20 28 76 65 63 74 6f bute-set! (vecto
32e0: 72 2d 72 65 66 20 68 65 61 64 65 72 63 6f 6c 20 r-ref headercol
32f0: 72 6f 77 6e 29 20 22 54 49 54 4c 45 22 20 6b 76 rown) "TITLE" kv
3300: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 73 65 al)).... (se
3310: 74 21 20 72 6f 77 6e 20 28 2b 20 72 6f 77 6e 20 t! rown (+ rown
3320: 31 29 29 29 29 0a 09 09 09 20 6b 65 79 2d 76 61 1)))).... key-va
3330: 6c 73 29 29 0a 0a 09 20 20 20 20 20 3b 3b 20 46 ls))... ;; F
3340: 6f 72 20 74 68 69 73 20 72 75 6e 20 6e 6f 77 20 or this run now
3350: 66 69 6c 6c 20 69 6e 20 74 68 65 20 62 75 74 74 fill in the butt
3360: 6f 6e 73 20 66 6f 72 20 65 61 63 68 20 74 65 73 ons for each tes
3370: 74 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 72 t.. (let ((r
3380: 6f 77 6e 20 30 29 0a 09 09 20 20 20 28 63 6f 6c own 0)... (col
3390: 75 6d 6e 64 61 74 20 20 28 76 65 63 74 6f 72 2d umndat (vector-
33a0: 72 65 66 20 74 61 62 6c 65 20 63 6f 6c 6e 29 29 ref table coln))
33b0: 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 ).. (for-e
33c0: 61 63 68 0a 09 09 28 6c 61 6d 62 64 61 20 28 74 ach...(lambda (t
33d0: 65 73 74 6e 61 6d 65 29 0a 09 09 20 20 28 6c 65 estname)... (le
33e0: 74 20 28 28 62 75 74 74 6f 6e 64 61 74 20 20 28 t ((buttondat (
33f0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3400: 65 66 61 75 6c 74 20 2a 62 75 74 74 6f 6e 64 61 efault *buttonda
3410: 74 2a 20 28 6d 6b 73 74 72 20 63 6f 6c 6e 20 72 t* (mkstr coln r
3420: 6f 77 6e 29 20 23 66 29 29 29 0a 09 09 20 20 20 own) #f)))...
3430: 20 28 69 66 20 62 75 74 74 6f 6e 64 61 74 0a 09 (if buttondat..
3440: 09 09 28 6c 65 74 2a 20 28 28 74 65 73 74 20 20 ..(let* ((test
3450: 20 20 20 20 20 28 6c 65 74 20 28 28 6d 61 74 63 (let ((matc
3460: 68 69 6e 67 20 28 66 69 6c 74 65 72 20 0a 09 09 hing (filter ...
3470: 09 09 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 ..... (lambda
3480: 20 28 78 29 28 65 71 75 61 6c 3f 20 28 74 65 73 (x)(equal? (tes
3490: 74 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e t:test-get-fulln
34a0: 61 6d 65 20 78 29 20 74 65 73 74 6e 61 6d 65 29 ame x) testname)
34b0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 74 65 73 )........ tes
34c0: 74 73 64 61 74 29 29 29 0a 09 09 09 09 09 20 20 tsdat)))......
34d0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6d 61 (if (null? ma
34e0: 74 63 68 69 6e 67 29 0a 09 09 09 09 09 09 20 28 tching)....... (
34f0: 76 65 63 74 6f 72 20 2d 31 20 2d 31 20 22 22 20 vector -1 -1 ""
3500: 22 22 20 22 22 20 30 20 22 22 20 22 22 20 30 20 "" "" 0 "" "" 0
3510: 22 22 20 22 22 20 22 22 20 30 20 22 22 20 22 22 "" "" "" 0 "" ""
3520: 29 0a 09 09 09 09 09 09 20 28 63 61 72 20 6d 61 )....... (car ma
3530: 74 63 68 69 6e 67 29 29 29 29 0a 09 09 09 20 20 tching))))....
3540: 20 20 20 20 20 28 74 65 73 74 6e 61 6d 65 20 20 (testname
3550: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
3560: 73 74 6e 61 6d 65 20 20 74 65 73 74 29 29 0a 09 stname test))..
3570: 09 09 20 20 20 20 20 20 20 28 69 74 65 6d 70 61 .. (itempa
3580: 74 68 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 th (db:test-ge
3590: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
35a0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 74 65 )).... (te
35b0: 73 74 66 75 6c 6c 6e 61 6d 65 20 28 74 65 73 74 stfullname (test
35c0: 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 :test-get-fullna
35d0: 6d 65 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 me test))....
35e0: 20 20 20 20 28 74 65 73 74 73 74 61 74 75 73 20 (teststatus
35f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
3600: 74 75 73 20 20 20 74 65 73 74 29 29 0a 09 09 09 tus test))....
3610: 20 20 20 20 20 20 20 28 74 65 73 74 73 74 61 74 (teststat
3620: 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d e (db:test-get-
3630: 73 74 61 74 65 20 20 20 20 74 65 73 74 29 29 0a state test)).
3640: 09 09 09 20 20 20 20 20 20 20 28 74 65 73 74 73 ... (tests
3650: 74 61 72 74 20 20 28 64 62 3a 74 65 73 74 2d 67 tart (db:test-g
3660: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 et-event_time te
3670: 73 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 st)).... (
3680: 72 75 6e 74 69 6d 65 20 20 20 20 28 64 62 3a 74 runtime (db:t
3690: 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 est-get-run_dura
36a0: 74 69 6f 6e 20 74 65 73 74 29 29 0a 09 09 09 20 tion test))....
36b0: 20 20 20 20 20 20 28 62 75 74 74 6f 6e 74 78 74 (buttontxt
36c0: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 65 (if (equal? te
36d0: 73 74 73 74 61 74 65 20 22 43 4f 4d 50 4c 45 54 ststate "COMPLET
36e0: 45 44 22 29 20 74 65 73 74 73 74 61 74 75 73 20 ED") teststatus
36f0: 74 65 73 74 73 74 61 74 65 29 29 0a 09 09 09 20 teststate))....
3700: 20 20 20 20 20 20 28 62 75 74 74 6f 6e 20 20 20 (button
3710: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6f (vector-ref co
3720: 6c 75 6d 6e 64 61 74 20 72 6f 77 6e 29 29 0a 09 lumndat rown))..
3730: 09 09 20 20 20 20 20 20 20 28 63 6f 6c 6f 72 20 .. (color
3740: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
3750: 2d 63 6f 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 65 -color-for-state
3760: 2d 73 74 61 74 75 73 20 74 65 73 74 73 74 61 74 -status teststat
3770: 65 20 74 65 73 74 73 74 61 74 75 73 29 29 0a 09 e teststatus))..
3780: 09 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 63 .. (curr-c
3790: 6f 6c 6f 72 20 28 76 65 63 74 6f 72 2d 72 65 66 olor (vector-ref
37a0: 20 62 75 74 74 6f 6e 64 61 74 20 31 29 29 20 3b buttondat 1)) ;
37b0: 3b 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 ; (iup:attribute
37c0: 20 62 75 74 74 6f 6e 20 22 42 47 43 4f 4c 4f 52 button "BGCOLOR
37d0: 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 63 ")).... (c
37e0: 75 72 72 2d 74 69 74 6c 65 20 28 76 65 63 74 6f urr-title (vecto
37f0: 72 2d 72 65 66 20 62 75 74 74 6f 6e 64 61 74 20 r-ref buttondat
3800: 32 29 29 29 20 3b 3b 20 28 69 75 70 3a 61 74 74 2))) ;; (iup:att
3810: 72 69 62 75 74 65 20 62 75 74 74 6f 6e 20 22 54 ribute button "T
3820: 49 54 4c 45 22 29 29 29 0a 09 09 09 20 20 28 69 ITLE"))).... (i
3830: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 63 f (not (equal? c
3840: 75 72 72 2d 63 6f 6c 6f 72 20 63 6f 6c 6f 72 29 urr-color color)
3850: 29 0a 09 09 09 20 20 20 20 20 20 28 69 75 70 3a ).... (iup:
3860: 61 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 62 attribute-set! b
3870: 75 74 74 6f 6e 20 22 42 47 43 4f 4c 4f 52 22 20 utton "BGCOLOR"
3880: 63 6f 6c 6f 72 29 29 0a 09 09 09 20 20 28 69 66 color)).... (if
3890: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 63 75 (not (equal? cu
38a0: 72 72 2d 74 69 74 6c 65 20 62 75 74 74 6f 6e 74 rr-title buttont
38b0: 78 74 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 xt)).... (i
38c0: 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 up:attribute-set
38d0: 21 20 62 75 74 74 6f 6e 20 22 54 49 54 4c 45 22 ! button "TITLE"
38e0: 20 20 20 62 75 74 74 6f 6e 74 78 74 29 29 0a 09 buttontxt))..
38f0: 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 .. (vector-set!
3900: 20 62 75 74 74 6f 6e 64 61 74 20 30 20 72 75 6e buttondat 0 run
3910: 2d 69 64 29 0a 09 09 09 20 20 28 76 65 63 74 6f -id).... (vecto
3920: 72 2d 73 65 74 21 20 62 75 74 74 6f 6e 64 61 74 r-set! buttondat
3930: 20 31 20 63 6f 6c 6f 72 29 0a 09 09 09 20 20 28 1 color).... (
3940: 76 65 63 74 6f 72 2d 73 65 74 21 20 62 75 74 74 vector-set! butt
3950: 6f 6e 64 61 74 20 32 20 62 75 74 74 6f 6e 74 78 ondat 2 buttontx
3960: 74 29 0a 09 09 09 20 20 28 76 65 63 74 6f 72 2d t).... (vector-
3970: 73 65 74 21 20 62 75 74 74 6f 6e 64 61 74 20 33 set! buttondat 3
3980: 20 74 65 73 74 29 0a 09 09 09 20 20 28 76 65 63 test).... (vec
3990: 74 6f 72 2d 73 65 74 21 20 62 75 74 74 6f 6e 64 tor-set! buttond
39a0: 61 74 20 34 20 72 75 6e 2d 6b 65 79 29 29 29 0a at 4 run-key))).
39b0: 09 09 20 20 20 20 28 73 65 74 21 20 72 6f 77 6e .. (set! rown
39c0: 20 28 2b 20 72 6f 77 6e 20 31 29 29 29 29 0a 09 (+ rown 1))))..
39d0: 09 2a 61 6c 6c 74 65 73 74 6e 61 6d 65 6c 73 74 .*alltestnamelst
39e0: 2a 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 *)).. (set!
39f0: 63 6f 6c 6e 20 28 2b 20 63 6f 6c 6e 20 31 29 29 coln (+ coln 1))
3a00: 29 29 0a 09 20 72 75 6e 73 29 29 29 29 0a 0a 28 )).. runs))))..(
3a10: 64 65 66 69 6e 65 20 28 6d 6b 73 74 72 20 2e 20 define (mkstr .
3a20: 78 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 x). (string-int
3a30: 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f ersperse (map co
3a40: 6e 63 20 78 29 20 22 2c 22 29 29 0a 0a 28 64 65 nc x) ","))..(de
3a50: 66 69 6e 65 20 28 75 70 64 61 74 65 2d 73 65 61 fine (update-sea
3a60: 72 63 68 20 78 20 76 61 6c 29 0a 20 20 3b 3b 20 rch x val). ;;
3a70: 28 70 72 69 6e 74 20 22 53 65 74 74 69 6e 67 20 (print "Setting
3a80: 73 65 61 72 63 68 20 66 6f 72 20 22 20 78 20 22 search for " x "
3a90: 20 74 6f 20 22 20 76 61 6c 29 0a 20 20 28 68 61 to " val). (ha
3aa0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 73 sh-table-set! *s
3ab0: 65 61 72 63 68 70 61 74 74 73 2a 20 78 20 76 61 earchpatts* x va
3ac0: 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 l))..(define (ma
3ad0: 72 6b 2d 66 6f 72 2d 75 70 64 61 74 65 29 0a 20 rk-for-update).
3ae0: 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 64 62 2d (set! *last-db-
3af0: 75 70 64 61 74 65 2d 74 69 6d 65 2a 20 30 29 0a update-time* 0).
3b00: 20 20 28 73 65 74 21 20 2a 64 65 6c 61 79 65 64 (set! *delayed
3b10: 2d 75 70 64 61 74 65 2a 20 31 29 0a 20 20 29 0a -update* 1). ).
3b20: 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 64 .(define (make-d
3b30: 61 73 68 62 6f 61 72 64 2d 62 75 74 74 6f 6e 73 ashboard-buttons
3b40: 20 6e 72 75 6e 73 20 6e 74 65 73 74 73 20 6b 65 nruns ntests ke
3b50: 79 6e 61 6d 65 73 29 0a 20 20 28 6c 65 74 2a 20 ynames). (let*
3b60: 28 28 6e 6b 65 79 73 20 20 20 28 6c 65 6e 67 74 ((nkeys (lengt
3b70: 68 20 6b 65 79 6e 61 6d 65 73 29 29 0a 09 20 28 h keynames)).. (
3b80: 72 75 6e 73 76 65 63 20 28 6d 61 6b 65 2d 76 65 runsvec (make-ve
3b90: 63 74 6f 72 20 6e 72 75 6e 73 29 29 0a 09 20 28 ctor nruns)).. (
3ba0: 68 65 61 64 65 72 20 20 28 6d 61 6b 65 2d 76 65 header (make-ve
3bb0: 63 74 6f 72 20 6e 72 75 6e 73 29 29 0a 09 20 28 ctor nruns)).. (
3bc0: 6c 66 74 63 6f 6c 20 20 28 6d 61 6b 65 2d 76 65 lftcol (make-ve
3bd0: 63 74 6f 72 20 6e 74 65 73 74 73 29 29 0a 09 20 ctor ntests))..
3be0: 28 6b 65 79 63 6f 6c 20 20 28 6d 61 6b 65 2d 76 (keycol (make-v
3bf0: 65 63 74 6f 72 20 6e 74 65 73 74 73 29 29 0a 09 ector ntests))..
3c00: 20 28 63 6f 6e 74 72 6f 6c 73 20 27 28 29 29 0a (controls '()).
3c10: 09 20 28 6c 66 74 6c 73 74 20 20 27 28 29 29 0a . (lftlst '()).
3c20: 09 20 28 68 64 72 6c 73 74 20 20 27 28 29 29 0a . (hdrlst '()).
3c30: 09 20 28 62 64 79 6c 73 74 20 20 27 28 29 29 0a . (bdylst '()).
3c40: 09 20 28 72 65 73 75 6c 74 20 20 27 28 29 29 0a . (result '()).
3c50: 09 20 28 69 20 20 20 20 20 20 20 30 29 29 0a 20 . (i 0)).
3c60: 20 20 20 3b 3b 20 63 6f 6e 74 72 6f 6c 73 20 28 ;; controls (
3c70: 61 6c 6f 6e 67 20 62 6f 74 74 6f 6d 29 0a 20 20 along bottom).
3c80: 20 20 28 73 65 74 21 20 63 6f 6e 74 72 6f 6c 73 (set! controls
3c90: 0a 09 20 20 28 69 75 70 3a 68 62 6f 78 0a 09 20 .. (iup:hbox..
3ca0: 20 20 28 69 75 70 3a 76 62 6f 78 0a 09 20 20 20 (iup:vbox..
3cb0: 20 28 69 75 70 3a 66 72 61 6d 65 20 0a 09 20 20 (iup:frame ..
3cc0: 20 20 20 23 3a 74 69 74 6c 65 20 22 66 69 6c 74 #:title "filt
3cd0: 65 72 20 74 65 73 74 20 61 6e 64 20 69 74 65 6d er test and item
3ce0: 73 22 0a 09 20 20 20 20 20 28 69 75 70 3a 68 62 s".. (iup:hb
3cf0: 6f 78 0a 09 20 20 20 20 20 20 28 69 75 70 3a 74 ox.. (iup:t
3d00: 65 78 74 62 6f 78 20 23 3a 73 69 7a 65 20 22 31 extbox #:size "1
3d10: 32 30 78 31 35 22 20 23 3a 66 6f 6e 74 73 69 7a 20x15" #:fontsiz
3d20: 65 20 22 31 30 22 20 23 3a 76 61 6c 75 65 20 22 e "10" #:value "
3d30: 25 22 0a 09 09 09 20 20 20 23 3a 61 63 74 69 6f %".... #:actio
3d40: 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 20 75 n (lambda (obj u
3d50: 6e 6b 20 76 61 6c 29 0a 09 09 09 09 20 20 20 20 nk val).....
3d60: 20 20 28 6d 61 72 6b 2d 66 6f 72 2d 75 70 64 61 (mark-for-upda
3d70: 74 65 29 0a 09 09 09 09 20 20 20 20 20 20 28 75 te)..... (u
3d80: 70 64 61 74 65 2d 73 65 61 72 63 68 20 22 74 65 pdate-search "te
3d90: 73 74 2d 6e 61 6d 65 22 20 76 61 6c 29 29 29 0a st-name" val))).
3da0: 09 20 20 20 20 20 20 3b 3b 28 69 75 70 3a 74 65 . ;;(iup:te
3db0: 78 74 62 6f 78 20 23 3a 73 69 7a 65 20 22 36 30 xtbox #:size "60
3dc0: 78 31 35 22 20 23 3a 66 6f 6e 74 73 69 7a 65 20 x15" #:fontsize
3dd0: 22 31 30 22 20 23 3a 76 61 6c 75 65 20 22 25 22 "10" #:value "%"
3de0: 0a 09 20 20 20 20 20 20 3b 3b 20 20 09 20 20 20 .. ;; .
3df0: 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 #:action (lambda
3e00: 20 28 6f 62 6a 20 75 6e 6b 20 76 61 6c 29 0a 09 (obj unk val)..
3e10: 20 20 20 20 20 20 3b 3b 20 20 09 09 20 20 20 20 ;; ..
3e20: 20 20 28 6d 61 72 6b 2d 66 6f 72 2d 75 70 64 61 (mark-for-upda
3e30: 74 65 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 09 te).. ;; .
3e40: 09 20 20 20 20 20 20 28 75 70 64 61 74 65 2d 73 . (update-s
3e50: 65 61 72 63 68 20 22 69 74 65 6d 2d 6e 61 6d 65 earch "item-name
3e60: 22 20 76 61 6c 29 29 0a 09 20 20 20 20 20 20 29 " val)).. )
3e70: 29 0a 09 20 20 20 20 28 69 75 70 3a 76 62 6f 78 ).. (iup:vbox
3e80: 0a 09 20 20 20 20 20 28 69 75 70 3a 68 62 6f 78 .. (iup:hbox
3e90: 0a 09 20 20 20 20 20 20 28 69 75 70 3a 62 75 74 .. (iup:but
3ea0: 74 6f 6e 20 22 53 6f 72 74 22 20 23 3a 61 63 74 ton "Sort" #:act
3eb0: 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a ion (lambda (obj
3ec0: 29 0a 09 09 09 09 09 20 20 20 20 28 73 65 74 21 )...... (set!
3ed0: 20 2a 74 65 73 74 73 2d 73 6f 72 74 2d 72 65 76 *tests-sort-rev
3ee0: 65 72 73 65 2a 20 28 6e 6f 74 20 2a 74 65 73 74 erse* (not *test
3ef0: 73 2d 73 6f 72 74 2d 72 65 76 65 72 73 65 2a 29 s-sort-reverse*)
3f00: 29 0a 09 09 09 09 09 20 20 20 20 28 69 75 70 3a )...... (iup:
3f10: 61 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 6f attribute-set! o
3f20: 62 6a 20 22 54 49 54 4c 45 22 20 28 69 66 20 2a bj "TITLE" (if *
3f30: 74 65 73 74 73 2d 73 6f 72 74 2d 72 65 76 65 72 tests-sort-rever
3f40: 73 65 2a 20 22 2b 53 6f 72 74 22 20 22 2d 53 6f se* "+Sort" "-So
3f50: 72 74 22 29 29 0a 09 09 09 09 09 20 20 20 20 28 rt"))...... (
3f60: 6d 61 72 6b 2d 66 6f 72 2d 75 70 64 61 74 65 29 mark-for-update)
3f70: 29 29 0a 09 20 20 20 20 20 20 28 69 75 70 3a 62 )).. (iup:b
3f80: 75 74 74 6f 6e 20 22 48 69 64 65 45 6d 70 74 79 utton "HideEmpty
3f90: 22 20 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 " #:action (lamb
3fa0: 64 61 20 28 6f 62 6a 29 0a 09 09 09 09 09 09 20 da (obj).......
3fb0: 28 73 65 74 21 20 2a 68 69 64 65 2d 65 6d 70 74 (set! *hide-empt
3fc0: 79 2d 72 75 6e 73 2a 20 28 6e 6f 74 20 2a 68 69 y-runs* (not *hi
3fd0: 64 65 2d 65 6d 70 74 79 2d 72 75 6e 73 2a 29 29 de-empty-runs*))
3fe0: 0a 09 09 09 09 09 09 20 28 69 75 70 3a 61 74 74 ....... (iup:att
3ff0: 72 69 62 75 74 65 2d 73 65 74 21 20 6f 62 6a 20 ribute-set! obj
4000: 22 54 49 54 4c 45 22 20 28 69 66 20 2a 68 69 64 "TITLE" (if *hid
4010: 65 2d 65 6d 70 74 79 2d 72 75 6e 73 2a 20 22 2b e-empty-runs* "+
4020: 48 69 64 65 22 20 22 2d 48 69 64 65 22 29 29 0a Hide" "-Hide")).
4030: 09 09 09 09 09 09 20 28 6d 61 72 6b 2d 66 6f 72 ...... (mark-for
4040: 2d 75 70 64 61 74 65 29 29 29 0a 09 20 20 20 20 -update)))..
4050: 20 20 28 69 75 70 3a 62 75 74 74 6f 6e 20 22 52 (iup:button "R
4060: 65 66 72 65 73 68 22 20 20 20 23 3a 61 63 74 69 efresh" #:acti
4070: 6f 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 on (lambda (obj)
4080: 0a 09 09 09 09 09 09 20 28 6d 61 72 6b 2d 66 6f ....... (mark-fo
4090: 72 2d 75 70 64 61 74 65 29 29 29 29 0a 09 20 20 r-update))))..
40a0: 20 20 20 28 69 75 70 3a 68 62 6f 78 0a 09 20 20 (iup:hbox..
40b0: 20 20 20 20 28 69 75 70 3a 62 75 74 74 6f 6e 20 (iup:button
40c0: 22 51 75 69 74 22 20 23 3a 61 63 74 69 6f 6e 20 "Quit" #:action
40d0: 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 28 69 66 (lambda (obj)(if
40e0: 20 2a 64 62 2a 20 28 73 71 6c 69 74 65 33 3a 66 *db* (sqlite3:f
40f0: 69 6e 61 6c 69 7a 65 21 20 2a 64 62 2a 29 29 28 inalize! *db*))(
4100: 65 78 69 74 29 29 29 0a 09 20 20 20 20 20 20 28 exit))).. (
4110: 69 75 70 3a 62 75 74 74 6f 6e 20 22 4d 6f 6e 69 iup:button "Moni
4120: 74 6f 72 22 20 23 3a 61 63 74 69 6f 6e 20 28 6c tor" #:action (l
4130: 61 6d 62 64 61 20 28 6f 62 6a 29 28 73 79 73 74 ambda (obj)(syst
4140: 65 6d 20 28 63 6f 6e 63 20 28 63 61 72 20 28 61 em (conc (car (a
4150: 72 67 76 29 29 22 20 2d 67 75 69 6d 6f 6e 69 74 rgv))" -guimonit
4160: 6f 72 20 26 22 29 29 29 29 29 0a 09 20 20 20 20 or &")))))..
4170: 20 29 29 0a 09 20 20 20 3b 3b 20 28 69 75 70 3a )).. ;; (iup:
4180: 62 75 74 74 6f 6e 20 22 3c 2d 20 20 4c 65 66 74 button "<- Left
4190: 22 20 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 " #:action (lamb
41a0: 64 61 20 28 6f 62 6a 29 28 73 65 74 21 20 2a 73 da (obj)(set! *s
41b0: 74 61 72 74 2d 72 75 6e 2d 6f 66 66 73 65 74 2a tart-run-offset*
41c0: 20 20 28 2b 20 2a 73 74 61 72 74 2d 72 75 6e 2d (+ *start-run-
41d0: 6f 66 66 73 65 74 2a 20 31 29 29 29 29 0a 09 20 offset* 1))))..
41e0: 20 20 3b 3b 20 28 69 75 70 3a 62 75 74 74 6f 6e ;; (iup:button
41f0: 20 22 55 70 20 20 20 20 20 5e 22 20 23 3a 61 63 "Up ^" #:ac
4200: 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 tion (lambda (ob
4210: 6a 29 28 73 65 74 21 20 2a 73 74 61 72 74 2d 74 j)(set! *start-t
4220: 65 73 74 2d 6f 66 66 73 65 74 2a 20 28 69 66 20 est-offset* (if
4230: 28 3e 20 2a 73 74 61 72 74 2d 74 65 73 74 2d 6f (> *start-test-o
4240: 66 66 73 65 74 2a 20 30 29 28 2d 20 2a 73 74 61 ffset* 0)(- *sta
4250: 72 74 2d 74 65 73 74 2d 6f 66 66 73 65 74 2a 20 rt-test-offset*
4260: 31 29 20 30 29 29 29 29 0a 09 20 20 20 3b 3b 20 1) 0)))).. ;;
4270: 28 69 75 70 3a 62 75 74 74 6f 6e 20 22 44 6f 77 (iup:button "Dow
4280: 6e 20 20 20 76 22 20 23 3a 61 63 74 69 6f 6e 20 n v" #:action
4290: 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 28 73 65 (lambda (obj)(se
42a0: 74 21 20 2a 73 74 61 72 74 2d 74 65 73 74 2d 6f t! *start-test-o
42b0: 66 66 73 65 74 2a 20 28 69 66 20 28 3e 3d 20 2a ffset* (if (>= *
42c0: 73 74 61 72 74 2d 74 65 73 74 2d 6f 66 66 73 65 start-test-offse
42d0: 74 2a 20 28 6c 65 6e 67 74 68 20 2a 61 6c 6c 74 t* (length *allt
42e0: 65 73 74 6e 61 6d 65 6c 73 74 2a 29 29 28 6c 65 estnamelst*))(le
42f0: 6e 67 74 68 20 2a 61 6c 6c 74 65 73 74 6e 61 6d ngth *alltestnam
4300: 65 6c 73 74 2a 29 28 2b 20 2a 73 74 61 72 74 2d elst*)(+ *start-
4310: 74 65 73 74 2d 6f 66 66 73 65 74 2a 20 31 29 29 test-offset* 1))
4320: 29 29 29 0a 09 20 20 20 3b 3b 20 28 69 75 70 3a ))).. ;; (iup:
4330: 62 75 74 74 6f 6e 20 22 52 69 67 68 74 20 2d 3e button "Right ->
4340: 22 20 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 " #:action (lamb
4350: 64 61 20 28 6f 62 6a 29 28 73 65 74 21 20 2a 73 da (obj)(set! *s
4360: 74 61 72 74 2d 72 75 6e 2d 6f 66 66 73 65 74 2a tart-run-offset*
4370: 20 20 28 69 66 20 28 3e 20 2a 73 74 61 72 74 2d (if (> *start-
4380: 72 75 6e 2d 6f 66 66 73 65 74 2a 20 30 29 28 2d run-offset* 0)(-
4390: 20 2a 73 74 61 72 74 2d 72 75 6e 2d 6f 66 66 73 *start-run-offs
43a0: 65 74 2a 20 31 29 20 30 29 29 29 29 0a 09 20 20 et* 1) 0))))..
43b0: 20 28 69 75 70 3a 66 72 61 6d 65 20 0a 09 20 20 (iup:frame ..
43c0: 20 20 23 3a 74 69 74 6c 65 20 22 68 69 64 65 22 #:title "hide"
43d0: 0a 09 20 20 20 20 28 69 75 70 3a 76 62 6f 78 0a .. (iup:vbox.
43e0: 09 20 20 20 20 20 28 61 70 70 6c 79 20 0a 09 20 . (apply ..
43f0: 20 20 20 20 20 69 75 70 3a 68 62 6f 78 0a 09 20 iup:hbox..
4400: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
4410: 61 20 28 73 74 61 74 75 73 29 0a 09 09 20 20 20 a (status)...
4420: 20 20 28 69 75 70 3a 74 6f 67 67 6c 65 20 73 74 (iup:toggle st
4430: 61 74 75 73 20 20 23 3a 61 63 74 69 6f 6e 20 20 atus #:action
4440: 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 20 76 61 (lambda (obj va
4450: 6c 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 l)....... (
4460: 6d 61 72 6b 2d 66 6f 72 2d 75 70 64 61 74 65 29 mark-for-update)
4470: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 69 66 ....... (if
4480: 20 28 65 71 3f 20 76 61 6c 20 31 29 0a 09 09 09 (eq? val 1)....
4490: 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c .... (hash-tabl
44a0: 65 2d 73 65 74 21 20 2a 73 74 61 74 75 73 2d 69 e-set! *status-i
44b0: 67 6e 6f 72 65 2d 68 61 73 68 2a 20 73 74 61 74 gnore-hash* stat
44c0: 75 73 20 23 74 29 0a 09 09 09 09 09 09 09 20 20 us #t)........
44d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 (hash-table-dele
44e0: 74 65 21 20 2a 73 74 61 74 75 73 2d 69 67 6e 6f te! *status-igno
44f0: 72 65 2d 68 61 73 68 2a 20 73 74 61 74 75 73 29 re-hash* status)
4500: 29 29 29 29 0a 09 20 20 20 20 20 20 27 28 22 50 )))).. '("P
4510: 41 53 53 22 20 22 46 41 49 4c 22 20 22 57 41 52 ASS" "FAIL" "WAR
4520: 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 N" "CHECK" "WAIV
4530: 45 44 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 ED" "STUCK/DEAD"
4540: 20 22 6e 2f 61 22 20 22 53 4b 49 50 22 29 29 29 "n/a" "SKIP")))
4550: 0a 09 20 20 20 20 20 28 61 70 70 6c 79 20 0a 09 .. (apply ..
4560: 20 20 20 20 20 20 69 75 70 3a 68 62 6f 78 0a 09 iup:hbox..
4570: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
4580: 64 61 20 28 73 74 61 74 65 29 0a 09 09 20 20 20 da (state)...
4590: 20 20 28 69 75 70 3a 74 6f 67 67 6c 65 20 73 74 (iup:toggle st
45a0: 61 74 65 20 20 20 23 3a 61 63 74 69 6f 6e 20 20 ate #:action
45b0: 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 20 76 61 (lambda (obj va
45c0: 6c 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 l)....... (
45d0: 6d 61 72 6b 2d 66 6f 72 2d 75 70 64 61 74 65 29 mark-for-update)
45e0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 69 66 ....... (if
45f0: 20 28 65 71 3f 20 76 61 6c 20 31 29 0a 09 09 09 (eq? val 1)....
4600: 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c .... (hash-tabl
4610: 65 2d 73 65 74 21 20 2a 73 74 61 74 65 2d 69 67 e-set! *state-ig
4620: 6e 6f 72 65 2d 68 61 73 68 2a 20 73 74 61 74 65 nore-hash* state
4630: 20 23 74 29 0a 09 09 09 09 09 09 09 20 20 28 68 #t)........ (h
4640: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
4650: 21 20 2a 73 74 61 74 65 2d 69 67 6e 6f 72 65 2d ! *state-ignore-
4660: 68 61 73 68 2a 20 73 74 61 74 65 29 29 29 29 29 hash* state)))))
4670: 0a 09 09 20 20 20 27 28 22 52 55 4e 4e 49 4e 47 ... '("RUNNING
4680: 22 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 49 " "COMPLETED" "I
4690: 4e 43 4f 4d 50 4c 45 54 45 22 20 22 4c 41 55 4e NCOMPLETE" "LAUN
46a0: 43 48 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 CHED" "NOT_START
46b0: 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 44 45 ED" "KILLED" "DE
46c0: 4c 45 54 45 44 22 29 29 29 0a 09 20 20 20 20 20 LETED")))..
46d0: 28 69 75 70 3a 76 61 6c 75 61 74 6f 72 20 23 3a (iup:valuator #:
46e0: 76 61 6c 75 65 63 68 61 6e 67 65 64 5f 63 62 20 valuechanged_cb
46f0: 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 0a 09 09 (lambda (obj)...
4700: 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 ... (let (
4710: 28 76 61 6c 20 28 69 6e 65 78 61 63 74 2d 3e 65 (val (inexact->e
4720: 78 61 63 74 20 28 72 6f 75 6e 64 20 28 2f 20 28 xact (round (/ (
4730: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
4740: 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 6f 62 iup:attribute ob
4750: 6a 20 22 56 41 4c 55 45 22 29 29 20 31 30 29 29 j "VALUE")) 10))
4760: 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 6f ))....... (o
4770: 6c 64 6d 61 78 20 20 20 28 73 74 72 69 6e 67 2d ldmax (string-
4780: 3e 6e 75 6d 62 65 72 20 28 69 75 70 3a 61 74 74 >number (iup:att
4790: 72 69 62 75 74 65 20 6f 62 6a 20 22 4d 41 58 22 ribute obj "MAX"
47a0: 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 )))....... (
47b0: 6d 61 78 72 75 6e 73 20 20 2a 74 6f 74 2d 72 75 maxruns *tot-ru
47c0: 6e 2d 63 6f 75 6e 74 2a 29 29 0a 09 09 09 09 09 n-count*))......
47d0: 09 20 28 73 65 74 21 20 2a 73 74 61 72 74 2d 72 . (set! *start-r
47e0: 75 6e 2d 6f 66 66 73 65 74 2a 20 76 61 6c 29 0a un-offset* val).
47f0: 09 09 09 09 09 09 20 28 6d 61 72 6b 2d 66 6f 72 ...... (mark-for
4800: 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 09 20 -update).......
4810: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 (debug:print 6 "
4820: 2a 73 74 61 72 74 2d 72 75 6e 2d 6f 66 66 73 65 *start-run-offse
4830: 74 2a 20 22 20 2a 73 74 61 72 74 2d 72 75 6e 2d t* " *start-run-
4840: 6f 66 66 73 65 74 2a 20 22 20 6d 61 78 72 75 6e offset* " maxrun
4850: 73 3a 20 22 20 6d 61 78 72 75 6e 73 20 22 2c 20 s: " maxruns ",
4860: 76 61 6c 3a 20 22 20 76 61 6c 20 22 20 6f 6c 64 val: " val " old
4870: 6d 61 78 3a 20 22 20 6f 6c 64 6d 61 78 29 0a 09 max: " oldmax)..
4880: 09 09 09 09 09 20 28 69 75 70 3a 61 74 74 72 69 ..... (iup:attri
4890: 62 75 74 65 2d 73 65 74 21 20 6f 62 6a 20 22 4d bute-set! obj "M
48a0: 41 58 22 20 28 2a 20 6d 61 78 72 75 6e 73 20 31 AX" (* maxruns 1
48b0: 30 29 29 29 29 0a 09 09 09 20 20 20 23 3a 65 78 0)))).... #:ex
48c0: 70 61 6e 64 20 22 59 45 53 22 0a 09 09 09 20 20 pand "YES"....
48d0: 20 23 3a 6d 61 78 20 28 2a 20 31 30 20 28 6c 65 #:max (* 10 (le
48e0: 6e 67 74 68 20 2a 61 6c 6c 72 75 6e 73 2a 29 29 ngth *allruns*))
48f0: 29 29 29 0a 09 20 20 20 3b 28 69 75 70 3a 62 75 ))).. ;(iup:bu
4900: 74 74 6f 6e 20 22 69 6e 63 20 72 6f 77 73 22 20 tton "inc rows"
4910: 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 #:action (lambda
4920: 20 28 6f 62 6a 29 28 73 65 74 21 20 2a 6e 75 6d (obj)(set! *num
4930: 2d 74 65 73 74 73 2a 20 28 2b 20 2a 6e 75 6d 2d -tests* (+ *num-
4940: 74 65 73 74 73 2a 20 31 29 29 29 29 0a 09 20 20 tests* 1))))..
4950: 20 3b 28 69 75 70 3a 62 75 74 74 6f 6e 20 22 64 ;(iup:button "d
4960: 65 63 20 72 6f 77 73 22 20 23 3a 61 63 74 69 6f ec rows" #:actio
4970: 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 28 n (lambda (obj)(
4980: 73 65 74 21 20 2a 6e 75 6d 2d 74 65 73 74 73 2a set! *num-tests*
4990: 20 28 69 66 20 28 3e 20 2a 6e 75 6d 2d 74 65 73 (if (> *num-tes
49a0: 74 73 2a 20 30 29 28 2d 20 2a 6e 75 6d 2d 74 65 ts* 0)(- *num-te
49b0: 73 74 73 2a 20 31 29 20 30 29 29 29 29 0a 09 20 sts* 1) 0))))..
49c0: 20 20 29 0a 09 20 20 29 0a 20 20 20 20 0a 20 20 ).. ). .
49d0: 20 20 3b 3b 20 63 72 65 61 74 65 20 74 68 65 20 ;; create the
49e0: 6c 65 66 74 20 6d 6f 73 74 20 63 6f 6c 75 6d 6e left most column
49f0: 20 66 6f 72 20 74 68 65 20 72 75 6e 20 6b 65 79 for the run key
4a00: 20 6e 61 6d 65 73 20 61 6e 64 20 74 68 65 20 74 names and the t
4a10: 65 73 74 20 6e 61 6d 65 73 20 0a 20 20 20 20 28 est names . (
4a20: 73 65 74 21 20 6c 66 74 6c 73 74 20 28 6c 69 73 set! lftlst (lis
4a30: 74 20 28 69 75 70 3a 68 62 6f 78 0a 09 09 09 28 t (iup:hbox....(
4a40: 69 75 70 3a 6c 61 62 65 6c 29 20 3b 3b 20 28 69 iup:label) ;; (i
4a50: 75 70 3a 76 61 6c 75 61 74 6f 72 29 0a 09 09 09 up:valuator)....
4a60: 28 61 70 70 6c 79 20 69 75 70 3a 76 62 6f 78 20 (apply iup:vbox
4a70: 0a 09 09 09 20 20 20 20 20 20 20 28 6d 61 70 20 .... (map
4a80: 28 6c 61 6d 62 64 61 20 28 78 29 09 09 0a 09 09 (lambda (x).....
4a90: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 .. (let ((r
4aa0: 65 73 20 28 69 75 70 3a 68 62 6f 78 20 23 3a 65 es (iup:hbox #:e
4ab0: 78 70 61 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 xpand "HORIZONTA
4ac0: 4c 22 0a 09 09 09 09 09 09 20 20 28 69 75 70 3a L"....... (iup:
4ad0: 6c 61 62 65 6c 20 78 20 23 3a 73 69 7a 65 20 22 label x #:size "
4ae0: 78 31 35 22 20 23 3a 66 6f 6e 74 73 69 7a 65 20 x15" #:fontsize
4af0: 22 31 30 22 20 23 3a 65 78 70 61 6e 64 20 22 48 "10" #:expand "H
4b00: 4f 52 49 5a 4f 4e 54 41 4c 22 29 0a 09 09 09 09 ORIZONTAL").....
4b10: 09 09 20 20 28 69 75 70 3a 74 65 78 74 62 6f 78 .. (iup:textbox
4b20: 20 23 3a 73 69 7a 65 20 22 78 31 35 22 20 23 3a #:size "x15" #:
4b30: 66 6f 6e 74 73 69 7a 65 20 22 31 30 22 20 23 3a fontsize "10" #:
4b40: 76 61 6c 75 65 20 22 25 22 20 23 3a 65 78 70 61 value "%" #:expa
4b50: 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 4c 22 0a nd "HORIZONTAL".
4b60: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 23 3a ....... #:
4b70: 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 action (lambda (
4b80: 6f 62 6a 20 75 6e 6b 20 76 61 6c 29 0a 09 09 09 obj unk val)....
4b90: 09 09 09 09 09 09 20 20 28 6d 61 72 6b 2d 66 6f ...... (mark-fo
4ba0: 72 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 09 r-update).......
4bb0: 09 09 09 20 20 28 75 70 64 61 74 65 2d 73 65 61 ... (update-sea
4bc0: 72 63 68 20 78 20 76 61 6c 29 29 29 29 29 29 0a rch x val)))))).
4bd0: 09 09 09 09 09 28 73 65 74 21 20 69 20 28 2b 20 .....(set! i (+
4be0: 69 20 31 29 29 0a 09 09 09 09 09 72 65 73 29 29 i 1))......res))
4bf0: 0a 09 09 09 09 20 20 20 20 6b 65 79 6e 61 6d 65 ..... keyname
4c00: 73 29 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 s))))). (let
4c10: 6c 6f 6f 70 20 28 28 74 65 73 74 6e 75 6d 20 20 loop ((testnum
4c20: 30 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 0).. (res
4c30: 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 20 '())).
4c40: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 28 28 (cond. ((
4c50: 3e 3d 20 74 65 73 74 6e 75 6d 20 6e 74 65 73 74 >= testnum ntest
4c60: 73 29 0a 09 3b 3b 20 6e 6f 77 20 6c 66 74 6c 73 s)..;; now lftls
4c70: 74 20 77 69 6c 6c 20 62 65 20 61 6e 20 68 62 6f t will be an hbo
4c80: 78 20 77 69 74 68 20 74 68 65 20 74 65 73 74 20 x with the test
4c90: 6b 65 79 73 20 61 6e 64 20 74 68 65 20 74 65 73 keys and the tes
4ca0: 74 20 6e 61 6d 65 20 6c 61 62 65 6c 73 0a 09 28 t name labels..(
4cb0: 73 65 74 21 20 6c 66 74 6c 73 74 20 28 61 70 70 set! lftlst (app
4cc0: 65 6e 64 20 6c 66 74 6c 73 74 20 28 6c 69 73 74 end lftlst (list
4cd0: 20 28 69 75 70 3a 68 62 6f 78 20 20 23 3a 65 78 (iup:hbox #:ex
4ce0: 70 61 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 4c pand "HORIZONTAL
4cf0: 22 0a 09 09 09 09 09 20 20 20 28 69 75 70 3a 76 "...... (iup:v
4d00: 61 6c 75 61 74 6f 72 20 23 3a 76 61 6c 75 65 63 aluator #:valuec
4d10: 68 61 6e 67 65 64 5f 63 62 20 28 6c 61 6d 62 64 hanged_cb (lambd
4d20: 61 20 28 6f 62 6a 29 0a 09 09 09 09 09 09 09 09 a (obj).........
4d30: 09 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c . (let ((val
4d40: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
4d50: 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 (iup:attribute
4d60: 6f 62 6a 20 22 56 41 4c 55 45 22 29 29 29 0a 09 obj "VALUE")))..
4d70: 09 09 09 09 09 09 09 09 09 20 20 20 28 6f 6c 64 ......... (old
4d80: 6d 61 78 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 max (string->nu
4d90: 6d 62 65 72 20 28 69 75 70 3a 61 74 74 72 69 62 mber (iup:attrib
4da0: 75 74 65 20 6f 62 6a 20 22 4d 41 58 22 29 29 29 ute obj "MAX")))
4db0: 0a 09 09 09 09 09 09 09 09 09 09 20 20 20 28 6e ........... (n
4dc0: 65 77 6d 61 78 20 20 28 2a 20 31 30 20 28 6c 65 ewmax (* 10 (le
4dd0: 6e 67 74 68 20 2a 61 6c 6c 74 65 73 74 6e 61 6d ngth *alltestnam
4de0: 65 6c 73 74 2a 29 29 29 29 0a 09 09 09 09 09 09 elst*)))).......
4df0: 09 09 09 20 20 20 20 20 20 20 28 73 65 74 21 20 ... (set!
4e00: 2a 70 6c 65 61 73 65 2d 75 70 64 61 74 65 2d 62 *please-update-b
4e10: 75 74 74 6f 6e 73 2a 20 23 74 29 0a 09 09 09 09 uttons* #t).....
4e20: 09 09 09 09 09 20 20 20 20 20 20 20 28 73 65 74 ..... (set
4e30: 21 20 2a 73 74 61 72 74 2d 74 65 73 74 2d 6f 66 ! *start-test-of
4e40: 66 73 65 74 2a 20 28 69 6e 65 78 61 63 74 2d 3e fset* (inexact->
4e50: 65 78 61 63 74 20 28 72 6f 75 6e 64 20 28 2f 20 exact (round (/
4e60: 76 61 6c 20 31 30 29 29 29 29 0a 09 09 09 09 09 val 10))))......
4e70: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
4e80: 67 3a 70 72 69 6e 74 20 36 20 22 2a 73 74 61 72 g:print 6 "*star
4e90: 74 2d 74 65 73 74 2d 6f 66 66 73 65 74 2a 20 22 t-test-offset* "
4ea0: 20 2a 73 74 61 72 74 2d 74 65 73 74 2d 6f 66 66 *start-test-off
4eb0: 73 65 74 2a 20 22 20 76 61 6c 3a 20 22 20 76 61 set* " val: " va
4ec0: 6c 20 22 20 6e 65 77 6d 61 78 3a 20 22 20 6e 65 l " newmax: " ne
4ed0: 77 6d 61 78 20 22 20 6f 6c 64 6d 61 78 3a 20 22 wmax " oldmax: "
4ee0: 20 6f 6c 64 6d 61 78 29 0a 09 09 09 09 09 09 09 oldmax)........
4ef0: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 .. (if (<
4f00: 76 61 6c 20 31 30 29 0a 09 09 09 09 09 09 09 09 val 10).........
4f10: 09 09 20 20 20 28 69 75 70 3a 61 74 74 72 69 62 .. (iup:attrib
4f20: 75 74 65 2d 73 65 74 21 20 6f 62 6a 20 22 4d 41 ute-set! obj "MA
4f30: 58 22 20 6e 65 77 6d 61 78 29 29 0a 09 09 09 09 X" newmax)).....
4f40: 09 09 09 09 09 20 20 20 20 20 20 20 29 29 0a 09 ..... ))..
4f50: 09 09 09 09 09 09 20 23 3a 65 78 70 61 6e 64 20 ...... #:expand
4f60: 22 56 45 52 54 49 43 41 4c 22 20 0a 09 09 09 09 "VERTICAL" .....
4f70: 09 09 09 20 23 3a 6f 72 69 65 6e 74 61 74 69 6f ... #:orientatio
4f80: 6e 20 22 56 45 52 54 49 43 41 4c 22 29 0a 09 09 n "VERTICAL")...
4f90: 09 09 09 20 20 20 28 61 70 70 6c 79 20 69 75 70 ... (apply iup
4fa0: 3a 76 62 6f 78 20 28 72 65 76 65 72 73 65 20 72 :vbox (reverse r
4fb0: 65 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 es))))))).
4fc0: 20 28 65 6c 73 65 0a 09 28 6c 65 74 20 28 28 6c (else..(let ((l
4fd0: 61 62 6c 20 20 28 69 75 70 3a 62 75 74 74 6f 6e abl (iup:button
4fe0: 20 22 22 20 0a 09 09 09 09 20 23 3a 66 6c 61 74 "" ..... #:flat
4ff0: 20 22 59 45 53 22 20 0a 09 09 09 09 20 23 3a 61 "YES" ..... #:a
5000: 6c 69 67 6e 6d 65 6e 74 20 22 41 4c 45 46 54 22 lignment "ALEFT"
5010: 0a 09 09 09 09 20 3b 20 23 3a 69 6d 61 67 65 20 ..... ; #:image
5020: 69 6d 67 31 0a 09 09 09 09 20 3b 20 23 3a 69 6d img1..... ; #:im
5030: 70 72 65 73 73 20 69 6d 67 32 0a 09 09 09 09 20 press img2.....
5040: 23 3a 73 69 7a 65 20 22 78 31 35 22 0a 09 09 09 #:size "x15"....
5050: 09 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 . #:expand "HORI
5060: 5a 4f 4e 54 41 4c 22 0a 09 09 09 09 20 23 3a 66 ZONTAL"..... #:f
5070: 6f 6e 74 73 69 7a 65 20 22 31 30 22 0a 09 09 09 ontsize "10"....
5080: 09 20 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 . #:action (lamb
5090: 64 61 20 28 6f 62 6a 29 0a 09 09 09 09 09 20 20 da (obj)......
50a0: 20 20 28 6d 61 72 6b 2d 66 6f 72 2d 75 70 64 61 (mark-for-upda
50b0: 74 65 29 0a 09 09 09 09 09 20 20 20 20 28 74 6f te)...... (to
50c0: 67 67 6c 65 2d 68 69 64 65 20 74 65 73 74 6e 75 ggle-hide testnu
50d0: 6d 29 29 29 29 29 20 3b 3b 20 28 69 75 70 3a 61 m))))) ;; (iup:a
50e0: 74 74 72 69 62 75 74 65 20 6f 62 6a 20 22 54 49 ttribute obj "TI
50f0: 54 4c 45 22 29 29 29 29 0a 09 20 20 28 76 65 63 TLE")))).. (vec
5100: 74 6f 72 2d 73 65 74 21 20 6c 66 74 63 6f 6c 20 tor-set! lftcol
5110: 74 65 73 74 6e 75 6d 20 6c 61 62 6c 29 0a 09 20 testnum labl)..
5120: 20 28 6c 6f 6f 70 20 28 2b 20 74 65 73 74 6e 75 (loop (+ testnu
5130: 6d 20 31 29 28 63 6f 6e 73 20 6c 61 62 6c 20 72 m 1)(cons labl r
5140: 65 73 29 29 29 29 29 29 0a 20 20 20 20 3b 3b 20 es)))))). ;;
5150: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
5160: 28 72 75 6e 6e 75 6d 20 20 30 29 0a 09 20 20 20 (runnum 0)..
5170: 20 20 20 20 28 6b 65 79 6e 75 6d 20 20 30 29 0a (keynum 0).
5180: 09 20 20 20 20 20 20 20 28 6b 65 79 76 65 63 20 . (keyvec
5190: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 6e 6b (make-vector nk
51a0: 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 72 eys)).. (r
51b0: 65 73 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 es '())).
51c0: 20 20 28 63 6f 6e 64 20 3b 3b 20 6e 62 2f 2f 20 (cond ;; nb//
51d0: 6e 6f 20 65 6c 73 65 20 66 6f 72 20 74 68 69 73 no else for this
51e0: 20 61 70 70 72 6f 61 63 68 2e 0a 20 20 20 20 20 approach..
51f0: 20 20 28 28 3e 3d 20 72 75 6e 6e 75 6d 20 6e 72 ((>= runnum nr
5200: 75 6e 73 29 20 23 66 29 0a 20 20 20 20 20 20 20 uns) #f).
5210: 28 28 3e 3d 20 6b 65 79 6e 75 6d 20 6e 6b 65 79 ((>= keynum nkey
5220: 73 29 20 0a 09 28 76 65 63 74 6f 72 2d 73 65 74 s) ..(vector-set
5230: 21 20 68 65 61 64 65 72 20 72 75 6e 6e 75 6d 20 ! header runnum
5240: 6b 65 79 76 65 63 29 0a 09 28 73 65 74 21 20 68 keyvec)..(set! h
5250: 64 72 6c 73 74 20 28 63 6f 6e 73 20 28 61 70 70 drlst (cons (app
5260: 6c 79 20 69 75 70 3a 76 62 6f 78 20 28 72 65 76 ly iup:vbox (rev
5270: 65 72 73 65 20 72 65 73 29 29 20 68 64 72 6c 73 erse res)) hdrls
5280: 74 29 29 0a 09 28 6c 6f 6f 70 20 28 2b 20 72 75 t))..(loop (+ ru
5290: 6e 6e 75 6d 20 31 29 20 30 20 28 6d 61 6b 65 2d nnum 1) 0 (make-
52a0: 76 65 63 74 6f 72 20 6e 6b 65 79 73 29 20 27 28 vector nkeys) '(
52b0: 29 29 29 0a 20 20 20 20 20 20 20 28 65 6c 73 65 ))). (else
52c0: 0a 09 28 6c 65 74 20 28 28 6c 61 62 6c 20 20 28 ..(let ((labl (
52d0: 69 75 70 3a 6c 61 62 65 6c 20 22 22 20 23 3a 73 iup:label "" #:s
52e0: 69 7a 65 20 22 36 30 78 31 35 22 20 23 3a 66 6f ize "60x15" #:fo
52f0: 6e 74 73 69 7a 65 20 22 31 30 22 20 23 3a 65 78 ntsize "10" #:ex
5300: 70 61 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 4c pand "HORIZONTAL
5310: 22 29 29 29 20 3b 3b 20 23 3a 65 78 70 61 6e 64 "))) ;; #:expand
5320: 20 22 48 4f 52 49 5a 4f 4e 54 41 4c 22 0a 09 20 "HORIZONTAL"..
5330: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 6b 65 (vector-set! ke
5340: 79 76 65 63 20 6b 65 79 6e 75 6d 20 6c 61 62 6c yvec keynum labl
5350: 29 0a 09 20 20 28 6c 6f 6f 70 20 72 75 6e 6e 75 ).. (loop runnu
5360: 6d 20 28 2b 20 6b 65 79 6e 75 6d 20 31 29 20 6b m (+ keynum 1) k
5370: 65 79 76 65 63 20 28 63 6f 6e 73 20 6c 61 62 6c eyvec (cons labl
5380: 20 72 65 73 29 29 29 29 29 29 0a 20 20 20 20 3b res)))))). ;
5390: 3b 20 42 79 20 68 65 72 65 20 74 68 65 20 68 64 ; By here the hd
53a0: 72 6c 73 74 20 63 6f 6e 74 61 69 6e 73 20 61 20 rlst contains a
53b0: 6c 69 73 74 20 6f 66 20 76 62 6f 78 65 73 20 63 list of vboxes c
53c0: 6f 6e 74 61 69 6e 69 6e 67 20 6e 6b 65 79 73 20 ontaining nkeys
53d0: 6c 61 62 65 6c 73 0a 20 20 20 20 28 6c 65 74 20 labels. (let
53e0: 6c 6f 6f 70 20 28 28 72 75 6e 6e 75 6d 20 20 30 loop ((runnum 0
53f0: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 6e ).. (testn
5400: 75 6d 20 30 29 0a 09 20 20 20 20 20 20 20 28 74 um 0).. (t
5410: 65 73 74 76 65 63 20 20 28 6d 61 6b 65 2d 76 65 estvec (make-ve
5420: 63 74 6f 72 20 6e 74 65 73 74 73 29 29 0a 09 20 ctor ntests))..
5430: 20 20 20 20 20 20 28 72 65 73 20 20 20 20 27 28 (res '(
5440: 29 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 64 0a ))). (cond.
5450: 20 20 20 20 20 20 20 28 28 3e 3d 20 72 75 6e 6e ((>= runn
5460: 75 6d 20 6e 72 75 6e 73 29 20 23 66 29 20 3b 3b um nruns) #f) ;;
5470: 20 20 28 76 65 63 74 6f 72 20 74 61 62 6c 65 68 (vector tableh
5480: 65 61 64 65 72 20 72 75 6e 73 76 65 63 29 29 0a eader runsvec)).
5490: 20 20 20 20 20 20 20 28 28 3e 3d 20 74 65 73 74 ((>= test
54a0: 6e 75 6d 20 6e 74 65 73 74 73 29 20 0a 09 28 76 num ntests) ..(v
54b0: 65 63 74 6f 72 2d 73 65 74 21 20 72 75 6e 73 76 ector-set! runsv
54c0: 65 63 20 72 75 6e 6e 75 6d 20 74 65 73 74 76 65 ec runnum testve
54d0: 63 29 0a 09 28 73 65 74 21 20 62 64 79 6c 73 74 c)..(set! bdylst
54e0: 20 28 63 6f 6e 73 20 28 61 70 70 6c 79 20 69 75 (cons (apply iu
54f0: 70 3a 76 62 6f 78 20 28 72 65 76 65 72 73 65 20 p:vbox (reverse
5500: 72 65 73 29 29 20 62 64 79 6c 73 74 29 29 0a 09 res)) bdylst))..
5510: 28 6c 6f 6f 70 20 28 2b 20 72 75 6e 6e 75 6d 20 (loop (+ runnum
5520: 31 29 20 30 20 28 6d 61 6b 65 2d 76 65 63 74 6f 1) 0 (make-vecto
5530: 72 20 6e 74 65 73 74 73 29 20 27 28 29 29 29 0a r ntests) '())).
5540: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 28 6c (else..(l
5550: 65 74 2a 20 28 28 62 75 74 74 6f 6e 2d 6b 65 79 et* ((button-key
5560: 20 28 6d 6b 73 74 72 20 72 75 6e 6e 75 6d 20 74 (mkstr runnum t
5570: 65 73 74 6e 75 6d 29 29 0a 09 20 20 20 20 20 20 estnum))..
5580: 20 28 62 75 74 6e 20 20 20 20 20 20 20 28 69 75 (butn (iu
5590: 70 3a 62 75 74 74 6f 6e 20 22 22 20 3b 3b 20 62 p:button "" ;; b
55a0: 75 74 74 6f 6e 2d 6b 65 79 20 0a 09 09 09 09 20 utton-key .....
55b0: 20 20 20 20 20 20 23 3a 73 69 7a 65 20 22 36 30 #:size "60
55c0: 78 31 35 22 20 0a 09 09 09 09 20 20 20 20 20 20 x15" .....
55d0: 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 5a #:expand "HORIZ
55e0: 4f 4e 54 41 4c 22 0a 09 09 09 09 20 20 20 20 20 ONTAL".....
55f0: 20 20 23 3a 66 6f 6e 74 73 69 7a 65 20 22 31 30 #:fontsize "10
5600: 22 20 0a 09 09 09 09 20 20 20 20 20 20 20 23 3a " ..... #:
5610: 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 action (lambda (
5620: 78 29 0a 09 09 09 09 09 09 20 20 28 6c 65 74 2a x)....... (let*
5630: 20 28 28 74 6f 6f 6c 70 61 74 68 20 28 63 61 72 ((toolpath (car
5640: 20 28 61 72 67 76 29 29 29 0a 09 09 09 09 09 09 (argv))).......
5650: 09 20 28 62 75 74 74 6e 64 61 74 20 28 68 61 73 . (buttndat (has
5660: 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 62 75 74 h-table-ref *but
5670: 74 6f 6e 64 61 74 2a 20 62 75 74 74 6f 6e 2d 6b tondat* button-k
5680: 65 79 29 29 0a 09 09 09 09 09 09 09 20 28 74 65 ey))........ (te
5690: 73 74 2d 69 64 20 20 28 64 62 3a 74 65 73 74 2d st-id (db:test-
56a0: 67 65 74 2d 69 64 20 28 76 65 63 74 6f 72 2d 72 get-id (vector-r
56b0: 65 66 20 62 75 74 74 6e 64 61 74 20 33 29 29 29 ef buttndat 3)))
56c0: 0a 09 09 09 09 09 09 09 20 28 63 6d 64 20 20 28 ........ (cmd (
56d0: 63 6f 6e 63 20 74 6f 6f 6c 70 61 74 68 20 22 20 conc toolpath "
56e0: 2d 74 65 73 74 20 22 20 74 65 73 74 2d 69 64 20 -test " test-id
56f0: 22 26 22 29 29 29 0a 09 09 09 09 09 09 20 20 20 "&"))).......
5700: 20 3b 28 70 72 69 6e 74 20 22 4c 61 75 6e 63 68 ;(print "Launch
5710: 69 6e 67 20 22 20 63 6d 64 29 0a 09 09 09 09 09 ing " cmd)......
5720: 09 20 20 20 20 28 73 79 73 74 65 6d 20 63 6d 64 . (system cmd
5730: 29 29 29 29 29 29 0a 09 20 20 28 68 61 73 68 2d )))))).. (hash-
5740: 74 61 62 6c 65 2d 73 65 74 21 20 2a 62 75 74 74 table-set! *butt
5750: 6f 6e 64 61 74 2a 20 62 75 74 74 6f 6e 2d 6b 65 ondat* button-ke
5760: 79 20 28 76 65 63 74 6f 72 20 30 20 22 31 30 30 y (vector 0 "100
5770: 20 31 30 30 20 31 30 30 22 20 62 75 74 74 6f 6e 100 100" button
5780: 2d 6b 65 79 20 23 66 20 23 66 29 29 20 0a 09 20 -key #f #f)) ..
5790: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 74 65 (vector-set! te
57a0: 73 74 76 65 63 20 74 65 73 74 6e 75 6d 20 62 75 stvec testnum bu
57b0: 74 6e 29 0a 09 20 20 28 6c 6f 6f 70 20 72 75 6e tn).. (loop run
57c0: 6e 75 6d 20 28 2b 20 74 65 73 74 6e 75 6d 20 31 num (+ testnum 1
57d0: 29 20 74 65 73 74 76 65 63 20 28 63 6f 6e 73 20 ) testvec (cons
57e0: 62 75 74 6e 20 72 65 73 29 29 29 29 29 29 0a 20 butn res)))))).
57f0: 20 20 20 3b 3b 20 6e 6f 77 20 61 73 73 65 6d 62 ;; now assemb
5800: 6c 65 20 74 68 65 20 68 64 72 6c 73 74 20 61 6e le the hdrlst an
5810: 64 20 62 64 79 6c 73 74 20 61 6e 64 20 6b 69 63 d bdylst and kic
5820: 6b 20 6f 66 66 20 74 68 65 20 64 69 61 6c 6f 67 k off the dialog
5830: 0a 20 20 20 20 28 69 75 70 3a 73 68 6f 77 0a 20 . (iup:show.
5840: 20 20 20 20 28 69 75 70 3a 64 69 61 6c 6f 67 20 (iup:dialog
5850: 0a 20 20 20 20 20 20 23 3a 74 69 74 6c 65 20 22 . #:title "
5860: 4d 65 67 61 74 65 73 74 20 64 61 73 68 62 6f 61 Megatest dashboa
5870: 72 64 22 0a 20 20 20 20 20 20 28 69 75 70 3a 76 rd". (iup:v
5880: 62 6f 78 0a 09 28 61 70 70 6c 79 20 69 75 70 3a box..(apply iup:
5890: 68 62 6f 78 20 0a 09 20 20 20 20 20 20 20 28 63 hbox .. (c
58a0: 6f 6e 73 20 28 61 70 70 6c 79 20 69 75 70 3a 76 ons (apply iup:v
58b0: 62 6f 78 20 6c 66 74 6c 73 74 29 0a 09 09 20 20 box lftlst)...
58c0: 20 20 20 28 6c 69 73 74 20 0a 09 09 20 20 20 20 (list ...
58d0: 20 20 28 69 75 70 3a 76 62 6f 78 0a 09 09 20 20 (iup:vbox...
58e0: 20 20 20 20 20 3b 3b 20 74 68 65 20 68 65 61 64 ;; the head
58f0: 65 72 0a 09 09 20 20 20 20 20 20 20 28 61 70 70 er... (app
5900: 6c 79 20 69 75 70 3a 68 62 6f 78 20 28 72 65 76 ly iup:hbox (rev
5910: 65 72 73 65 20 68 64 72 6c 73 74 29 29 0a 09 09 erse hdrlst))...
5920: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 69 75 (apply iu
5930: 70 3a 68 62 6f 78 20 28 72 65 76 65 72 73 65 20 p:hbox (reverse
5940: 62 64 79 6c 73 74 29 29 29 29 29 29 0a 20 20 20 bdylst)))))).
5950: 20 20 20 20 63 6f 6e 74 72 6f 6c 73 29 29 29 0a controls))).
5960: 20 20 20 20 28 76 65 63 74 6f 72 20 6b 65 79 63 (vector keyc
5970: 6f 6c 20 6c 66 74 63 6f 6c 20 68 65 61 64 65 72 ol lftcol header
5980: 20 72 75 6e 73 76 65 63 29 29 29 0a 0a 28 69 66 runsvec)))..(if
5990: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
59a0: 72 67 20 22 2d 72 6f 77 73 22 29 0a 09 28 67 65 rg "-rows")..(ge
59b0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
59c0: 72 69 61 62 6c 65 20 22 44 41 53 48 42 4f 41 52 riable "DASHBOAR
59d0: 44 52 4f 57 53 22 20 29 29 0a 20 20 20 20 28 62 DROWS" )). (b
59e0: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 73 65 egin. (se
59f0: 74 21 20 2a 6e 75 6d 2d 74 65 73 74 73 2a 20 28 t! *num-tests* (
5a00: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
5a10: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
5a20: 20 22 2d 72 6f 77 73 22 29 0a 09 09 09 09 09 20 "-rows")......
5a30: 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
5a40: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
5a50: 44 41 53 48 42 4f 41 52 44 52 4f 57 53 22 29 29 DASHBOARDROWS"))
5a60: 29 29 0a 09 28 75 70 64 61 74 65 2d 72 75 6e 64 ))..(update-rund
5a70: 61 74 20 22 25 22 20 2a 6e 75 6d 2d 72 75 6e 73 at "%" *num-runs
5a80: 2a 20 22 25 2f 25 22 20 27 28 29 29 29 0a 20 20 * "%/%" '())).
5a90: 20 20 28 73 65 74 21 20 2a 6e 75 6d 2d 74 65 73 (set! *num-tes
5aa0: 74 73 2a 20 28 6d 69 6e 20 28 6d 61 78 20 28 75 ts* (min (max (u
5ab0: 70 64 61 74 65 2d 72 75 6e 64 61 74 20 22 25 22 pdate-rundat "%"
5ac0: 20 2a 6e 75 6d 2d 72 75 6e 73 2a 20 22 25 2f 25 *num-runs* "%/%
5ad0: 22 20 27 28 29 29 20 38 29 20 32 30 29 29 29 0a " '()) 8) 20))).
5ae0: 0a 28 64 65 66 69 6e 65 20 2a 74 69 6d 2a 20 28 .(define *tim* (
5af0: 69 75 70 3a 74 69 6d 65 72 29 29 0a 28 64 65 66 iup:timer)).(def
5b00: 69 6e 65 20 2a 6f 72 64 2a 20 23 66 29 0a 28 69 ine *ord* #f).(i
5b10: 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 up:attribute-set
5b20: 21 20 2a 74 69 6d 2a 20 22 54 49 4d 45 22 20 33 ! *tim* "TIME" 3
5b30: 30 30 29 0a 28 69 75 70 3a 61 74 74 72 69 62 75 00).(iup:attribu
5b40: 74 65 2d 73 65 74 21 20 2a 74 69 6d 2a 20 22 52 te-set! *tim* "R
5b50: 55 4e 22 20 22 59 45 53 22 29 0a 0a 3b 3b 20 4d UN" "YES")..;; M
5b60: 6f 76 65 20 74 68 69 73 20 73 74 75 66 66 20 74 ove this stuff t
5b70: 6f 20 64 62 2e 73 63 6d 20 46 49 58 4d 45 0a 3b o db.scm FIXME.;
5b80: 3b 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d ;.(define *last-
5b90: 64 62 2d 75 70 64 61 74 65 2d 74 69 6d 65 2a 20 db-update-time*
5ba0: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
5bb0: 6f 6e 2d 74 69 6d 65 20 28 63 6f 6e 63 20 2a 74 on-time (conc *t
5bc0: 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 65 oppath* "/megate
5bd0: 73 74 2e 64 62 22 29 29 29 0a 28 64 65 66 69 6e st.db"))).(defin
5be0: 65 20 28 64 62 3a 62 65 65 6e 2d 63 68 61 6e 67 e (db:been-chang
5bf0: 65 64 29 0a 20 20 28 3e 20 28 66 69 6c 65 2d 6d ed). (> (file-m
5c00: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
5c10: 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
5c20: 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 29 "/megatest.db")
5c30: 29 20 2a 6c 61 73 74 2d 64 62 2d 75 70 64 61 74 ) *last-db-updat
5c40: 65 2d 74 69 6d 65 2a 29 29 0a 28 64 65 66 69 6e e-time*)).(defin
5c50: 65 20 28 64 62 3a 73 65 74 2d 64 62 2d 75 70 64 e (db:set-db-upd
5c60: 61 74 65 2d 74 69 6d 65 29 0a 20 20 28 73 65 74 ate-time). (set
5c70: 21 20 2a 6c 61 73 74 2d 64 62 2d 75 70 64 61 74 ! *last-db-updat
5c80: 65 2d 74 69 6d 65 2a 20 28 66 69 6c 65 2d 6d 6f e-time* (file-mo
5c90: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
5ca0: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
5cb0: 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 "/megatest.db"))
5cc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
5cd0: 2d 75 70 64 61 74 65 20 78 29 0a 20 20 28 75 70 -update x). (up
5ce0: 64 61 74 65 2d 62 75 74 74 6f 6e 73 20 75 69 64 date-buttons uid
5cf0: 61 74 20 2a 6e 75 6d 2d 72 75 6e 73 2a 20 2a 6e at *num-runs* *n
5d00: 75 6d 2d 74 65 73 74 73 2a 29 0a 20 20 3b 3b 20 um-tests*). ;;
5d10: 28 69 66 20 28 64 62 3a 62 65 65 6e 2d 63 68 61 (if (db:been-cha
5d20: 6e 67 65 64 29 0a 20 20 28 62 65 67 69 6e 0a 20 nged). (begin.
5d30: 20 20 20 28 75 70 64 61 74 65 2d 72 75 6e 64 61 (update-runda
5d40: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
5d50: 66 2f 64 65 66 61 75 6c 74 20 2a 73 65 61 72 63 f/default *searc
5d60: 68 70 61 74 74 73 2a 20 22 72 75 6e 6e 61 6d 65 hpatts* "runname
5d70: 22 20 22 25 22 29 20 2a 6e 75 6d 2d 72 75 6e 73 " "%") *num-runs
5d80: 2a 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 *... (hash-tab
5d90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
5da0: 73 65 61 72 63 68 70 61 74 74 73 2a 20 22 74 65 searchpatts* "te
5db0: 73 74 2d 6e 61 6d 65 22 20 22 25 2f 25 22 29 0a st-name" "%/%").
5dc0: 09 09 20 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 .. ;; (hash-ta
5dd0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5de0: 2a 73 65 61 72 63 68 70 61 74 74 73 2a 20 22 69 *searchpatts* "i
5df0: 74 65 6d 2d 6e 61 6d 65 22 20 22 25 22 29 0a 09 tem-name" "%")..
5e00: 09 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 . (let ((res '
5e10: 28 29 29 29 0a 09 09 20 20 20 20 20 28 66 6f 72 ()))... (for
5e20: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
5e30: 65 79 29 0a 09 09 09 09 20 28 69 66 20 28 6e 6f ey)..... (if (no
5e40: 74 20 28 65 71 75 61 6c 3f 20 6b 65 79 20 22 72 t (equal? key "r
5e50: 75 6e 6e 61 6d 65 22 29 29 0a 09 09 09 09 20 20 unname")).....
5e60: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 (let ((val (h
5e70: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5e80: 66 61 75 6c 74 20 2a 73 65 61 72 63 68 70 61 74 fault *searchpat
5e90: 74 73 2a 20 6b 65 79 20 23 66 29 29 29 0a 09 09 ts* key #f)))...
5ea0: 09 09 20 20 20 20 20 20 20 28 69 66 20 76 61 6c .. (if val
5eb0: 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 (set! res (cons
5ec0: 20 28 6c 69 73 74 20 6b 65 79 20 76 61 6c 29 20 (list key val)
5ed0: 72 65 73 29 29 29 29 29 29 0a 09 09 09 20 20 20 res))))))....
5ee0: 20 20 20 20 2a 64 62 6b 65 79 73 2a 29 0a 09 09 *dbkeys*)...
5ef0: 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 3b res)). ;
5f00: 20 28 64 62 3a 73 65 74 2d 64 62 2d 75 70 64 61 (db:set-db-upda
5f10: 74 65 2d 74 69 6d 65 29 0a 20 20 20 20 29 29 0a te-time). )).
5f20: 0a 28 63 6f 6e 64 20 0a 20 28 28 61 72 67 73 3a .(cond . ((args:
5f30: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 22 29 0a get-arg "-run").
5f40: 20 20 28 6c 65 74 20 28 28 72 75 6e 69 64 20 28 (let ((runid (
5f50: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
5f60: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
5f70: 75 6e 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 un")))). (if
5f80: 72 75 6e 69 64 0a 09 28 62 65 67 69 6e 0a 09 20 runid..(begin..
5f90: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 20 (lambda (x)..
5fa0: 20 20 28 6f 6e 2d 65 78 69 74 20 28 6c 61 6d 62 (on-exit (lamb
5fb0: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
5fc0: 69 66 20 2a 64 62 2a 20 28 73 71 6c 69 74 65 33 if *db* (sqlite3
5fd0: 3a 66 69 6e 61 6c 69 7a 65 21 20 2a 64 62 2a 29 :finalize! *db*)
5fe0: 29 29 29 0a 09 20 20 20 20 28 63 64 62 3a 72 65 ))).. (cdb:re
5ff0: 6d 6f 74 65 2d 72 75 6e 20 65 78 61 6d 69 6e 65 mote-run examine
6000: 2d 72 75 6e 20 2a 64 62 2a 20 72 75 6e 69 64 29 -run *db* runid)
6010: 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 ))..(begin.. (p
6020: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 72 75 6e rint "ERROR: run
6030: 69 64 20 69 73 20 6e 6f 74 20 61 20 6e 75 6d 62 id is not a numb
6040: 65 72 20 22 20 28 61 72 67 73 3a 67 65 74 2d 61 er " (args:get-a
6050: 72 67 20 22 2d 72 75 6e 22 29 29 0a 09 20 20 28 rg "-run")).. (
6060: 65 78 69 74 20 31 29 29 29 29 29 0a 20 28 28 61 exit 1))))). ((a
6070: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 rgs:get-arg "-te
6080: 73 74 22 29 0a 20 20 20 20 28 6c 65 74 20 28 28 st"). (let ((
6090: 74 65 73 74 69 64 20 28 73 74 72 69 6e 67 2d 3e testid (string->
60a0: 6e 75 6d 62 65 72 20 28 61 72 67 73 3a 67 65 74 number (args:get
60b0: 2d 61 72 67 20 22 2d 74 65 73 74 22 29 29 29 29 -arg "-test"))))
60c0: 0a 20 20 20 20 28 69 66 20 74 65 73 74 69 64 0a . (if testid.
60d0: 09 28 65 78 61 6d 69 6e 65 2d 74 65 73 74 20 74 .(examine-test t
60e0: 65 73 74 69 64 29 0a 09 28 62 65 67 69 6e 0a 09 estid)..(begin..
60f0: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
6100: 20 74 65 73 74 69 64 20 69 73 20 6e 6f 74 20 61 testid is not a
6110: 20 6e 75 6d 62 65 72 20 22 20 28 61 72 67 73 3a number " (args:
6120: 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 22 29 get-arg "-test")
6130: 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 29 ).. (exit 1))))
6140: 29 0a 20 28 28 61 72 67 73 3a 67 65 74 2d 61 72 ). ((args:get-ar
6150: 67 20 22 2d 67 75 69 6d 6f 6e 69 74 6f 72 22 29 g "-guimonitor")
6160: 0a 20 20 28 67 75 69 2d 6d 6f 6e 69 74 6f 72 20 . (gui-monitor
6170: 2a 64 62 2a 29 29 0a 20 28 65 6c 73 65 0a 20 20 *db*)). (else.
6180: 28 73 65 74 21 20 75 69 64 61 74 20 28 6d 61 6b (set! uidat (mak
6190: 65 2d 64 61 73 68 62 6f 61 72 64 2d 62 75 74 74 e-dashboard-butt
61a0: 6f 6e 73 20 2a 6e 75 6d 2d 72 75 6e 73 2a 20 2a ons *num-runs* *
61b0: 6e 75 6d 2d 74 65 73 74 73 2a 20 2a 64 62 6b 65 num-tests* *dbke
61c0: 79 73 2a 29 29 0a 20 20 28 69 75 70 3a 63 61 6c ys*)). (iup:cal
61d0: 6c 62 61 63 6b 2d 73 65 74 21 20 2a 74 69 6d 2a lback-set! *tim*
61e0: 0a 09 09 20 20 20 20 20 22 41 43 54 49 4f 4e 5f ... "ACTION_
61f0: 43 42 22 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 CB"... (lamb
6200: 64 61 20 28 78 29 0a 09 09 20 20 20 20 20 20 20 da (x)...
6210: 28 72 75 6e 2d 75 70 64 61 74 65 20 78 29 29 29 (run-update x)))
6220: 29 29 0a 09 09 20 20 20 20 20 20 20 3b 28 70 72 ))... ;(pr
6230: 69 6e 74 20 78 29 29 29 29 29 0a 0a 28 69 75 70 int x)))))..(iup
6240: 3a 6d 61 69 6e 2d 6c 6f 6f 70 29 0a :main-loop).