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 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 unit commonmod))
03a0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
03b0: 6d 74 61 72 67 73 29 29 0a 0a 28 6d 6f 64 75 6c mtargs))..(modul
03c0: 65 20 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 2a 0a 09 e commonmod..*..
03d0: 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 20 .(import scheme
03e0: 63 68 69 63 6b 65 6e 20 64 61 74 61 2d 73 74 72 chicken data-str
03f0: 75 63 74 75 72 65 73 20 65 78 74 72 61 73 29 0a uctures extras).
0400: 09 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 ..(import (prefi
0410: 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 x sqlite3 sqlite
0420: 33 3a 29 20 70 6f 73 69 78 20 74 79 70 65 64 2d 3:) posix typed-
0430: 72 65 63 6f 72 64 73 20 73 72 66 69 2d 31 38 0a records srfi-18.
0440: 09 73 72 66 69 2d 31 20 66 69 6c 65 73 20 66 6f .srfi-1 files fo
0450: 72 6d 61 74 20 73 72 66 69 2d 31 33 20 6d 61 74 rmat srfi-13 mat
0460: 63 68 61 62 6c 65 20 0a 09 73 72 66 69 2d 36 39 chable ..srfi-69
0470: 20 70 6f 72 74 73 0a 09 72 65 67 65 78 2d 63 61 ports..regex-ca
0480: 73 65 20 72 65 67 65 78 20 68 6f 73 74 69 6e 66 se regex hostinf
0490: 6f 20 73 72 66 69 2d 34 0a 09 70 6b 74 73 20 28 o srfi-4..pkts (
04a0: 70 72 65 66 69 78 20 64 62 69 20 64 62 69 3a 29 prefix dbi dbi:)
04b0: 0a 09 73 74 61 63 6b 0a 09 6d 64 35 0a 09 6d 65 ..stack..md5..me
04c0: 73 73 61 67 65 2d 64 69 67 65 73 74 0a 09 28 70 ssage-digest..(p
04d0: 72 65 66 69 78 20 6d 74 63 6f 6e 66 69 67 66 20 refix mtconfigf
04e0: 63 6f 6e 66 69 67 66 3a 29 0a 09 73 74 6d 6c 32 configf:)..stml2
04f0: 0a 09 3b 3b 20 28 70 72 65 66 69 78 20 6d 61 72 ..;; (prefix mar
0500: 67 73 20 61 72 67 73 3a 29 0a 09 7a 33 20 28 70 gs args:)..z3 (p
0510: 72 65 66 69 78 20 62 61 73 65 36 34 20 62 61 73 refix base64 bas
0520: 65 36 34 3a 29 29 0a 0a 28 69 6d 70 6f 72 74 20 e64:))..(import
0530: 28 70 72 65 66 69 78 20 6d 74 61 72 67 73 20 61 (prefix mtargs a
0540: 72 67 73 3a 29 29 0a 0a 28 69 6e 63 6c 75 64 65 rgs:))..(include
0550: 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 "common_records
0560: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0570: 22 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c "megatest-fossil
0580: 2d 68 61 73 68 2e 73 63 6d 22 29 0a 28 69 6e 63 -hash.scm").(inc
0590: 6c 75 64 65 20 22 6d 65 67 61 74 65 73 74 2d 76 lude "megatest-v
05a0: 65 72 73 69 6f 6e 2e 73 63 6d 22 29 0a 0a 20 3b ersion.scm").. ;
05b0: 3b 20 6e 6f 20 6e 65 65 64 20 74 6f 20 65 78 70 ; no need to exp
05c0: 6f 72 74 20 74 68 69 73 0a 28 64 65 66 69 6e 65 ort this.(define
05d0: 20 2a 76 65 72 62 6f 73 69 74 79 2d 63 61 63 68 *verbosity-cach
05e0: 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 e* (make-hash-ta
05f0: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 76 ble)).(define *v
0600: 65 72 62 6f 73 69 74 79 2a 20 30 29 0a 0a 0a 0a erbosity* 0)....
0610: 3b 3b 20 47 4c 4f 42 41 4c 53 0a 0a 3b 3b 20 43 ;; GLOBALS..;; C
0620: 4f 4e 54 45 58 54 53 0a 23 3b 28 64 65 66 73 74 ONTEXTS.#;(defst
0630: 72 75 63 74 20 63 78 74 0a 20 20 28 74 61 73 6b ruct cxt. (task
0640: 64 62 20 23 66 29 0a 20 20 28 63 6d 75 74 65 78 db #f). (cmutex
0650: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 29 0a (make-mutex))).
0660: 3b 3b 20 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 ;; (define *cont
0670: 65 78 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 exts* (make-hash
0680: 2d 74 61 62 6c 65 29 29 0a 3b 3b 20 28 64 65 66 -table)).;; (def
0690: 69 6e 65 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 ine *context-mut
06a0: 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 ex* (make-mutex)
06b0: 29 0a 0a 3b 3b 20 3b 3b 20 73 61 66 65 20 6d 65 )..;; ;; safe me
06c0: 74 68 6f 64 20 66 6f 72 20 61 63 63 65 73 73 69 thod for accessi
06d0: 6e 67 20 61 20 63 6f 6e 74 65 78 74 20 67 69 76 ng a context giv
06e0: 65 6e 20 61 20 74 6f 70 70 61 74 68 0a 3b 3b 20 en a toppath.;;
06f0: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 ;;.;; (define (c
0700: 6f 6d 6d 6f 6e 3a 77 69 74 68 2d 63 78 74 20 74 ommon:with-cxt t
0710: 6f 70 70 61 74 68 20 70 72 6f 63 29 0a 3b 3b 20 oppath proc).;;
0720: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0730: 63 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 29 0a context-mutex*).
0740: 3b 3b 20 20 20 28 6c 65 74 20 28 28 63 78 74 20 ;; (let ((cxt
0750: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
0760: 64 65 66 61 75 6c 74 20 2a 63 6f 6e 74 65 78 74 default *context
0770: 73 2a 20 74 6f 70 70 61 74 68 20 23 66 29 29 29 s* toppath #f)))
0780: 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 .;; (if (not
0790: 20 63 78 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 cxt).;;
07a0: 20 28 73 65 74 21 20 63 78 74 20 28 6c 65 74 20 (set! cxt (let
07b0: 28 28 78 20 28 6d 61 6b 65 2d 63 78 74 29 29 29 ((x (make-cxt)))
07c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
07d0: 20 2a 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 *contexts* topp
07e0: 61 74 68 20 78 29 20 78 29 29 29 0a 3b 3b 20 20 ath x) x))).;;
07f0: 20 20 20 28 6c 65 74 20 28 28 63 78 74 2d 6d 75 (let ((cxt-mu
0800: 74 65 78 20 28 63 78 74 2d 6d 75 74 65 78 20 63 tex (cxt-mutex c
0810: 78 74 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 xt))).;; (
0820: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 63 mutex-unlock! *c
0830: 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 29 0a 3b ontext-mutex*).;
0840: 3b 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c ; (mutex-l
0850: 6f 63 6b 21 20 63 78 74 2d 6d 75 74 65 78 29 0a ock! cxt-mutex).
0860: 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ;; (let ((
0870: 72 65 73 20 28 70 72 6f 63 20 63 78 74 29 29 29 res (proc cxt)))
0880: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 6d 75 74 .;; (mut
0890: 65 78 2d 75 6e 6c 6f 63 6b 21 20 63 78 74 2d 6d ex-unlock! cxt-m
08a0: 75 74 65 78 29 0a 3b 3b 20 20 20 20 20 20 20 20 utex).;;
08b0: 20 72 65 73 29 29 29 29 0a 20 20 20 20 20 20 20 res)))).
08c0: 20 0a 3b 3b 20 41 20 68 61 73 68 20 74 61 62 6c .;; A hash tabl
08d0: 65 20 74 68 61 74 20 63 61 6e 20 62 65 20 61 63 e that can be ac
08e0: 63 65 73 73 65 64 20 62 79 20 23 7b 73 63 68 65 cessed by #{sche
08f0: 6d 65 20 2e 2e 2e 7d 20 63 61 6c 6c 73 20 69 6e me ...} calls in
0900: 0a 3b 3b 20 63 6f 6e 66 69 67 20 66 69 6c 65 73 .;; config files
0910: 2e 20 41 6c 6c 6f 77 73 20 63 6f 6d 6d 75 6e 69 . Allows communi
0920: 63 61 74 69 6e 67 20 62 65 74 77 65 65 6e 20 63 cating between c
0930: 6f 6e 66 67 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 onfgs.;;.(define
0940: 20 2a 75 73 65 72 2d 68 61 73 68 2d 64 61 74 61 *user-hash-data
0950: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
0960: 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 64 le))..(define *d
0970: 62 2d 6b 65 79 73 2a 20 23 66 29 0a 0a 28 64 65 b-keys* #f)..(de
0980: 66 69 6e 65 20 2a 70 6b 74 73 2d 69 6e 66 6f 2a fine *pkts-info*
0990: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
09a0: 61 62 6c 65 29 29 20 3b 3b 20 73 74 6f 72 65 20 able)) ;; store
09b0: 73 74 75 66 66 20 6c 69 6b 65 20 74 68 65 20 6c stuff like the l
09c0: 61 73 74 20 70 61 72 65 6e 74 20 68 65 72 65 0a ast parent here.
09d0: 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 69 (define *configi
09e0: 6e 66 6f 2a 20 20 20 23 66 29 20 20 20 3b 3b 20 nfo* #f) ;;
09f0: 72 61 77 20 72 65 73 75 6c 74 73 20 66 72 6f 6d raw results from
0a00: 20 73 65 74 75 70 2c 20 69 6e 63 6c 75 64 65 73 setup, includes
0a10: 20 74 6f 70 70 61 74 68 20 61 6e 64 20 74 61 62 toppath and tab
0a20: 6c 65 20 66 72 6f 6d 20 6d 65 67 61 74 65 73 74 le from megatest
0a30: 2e 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 .config.(define
0a40: 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 23 *runconfigdat* #
0a50: 66 29 20 20 20 3b 3b 20 72 75 6e 20 63 6f 6e 66 f) ;; run conf
0a60: 69 67 73 20 64 61 74 61 0a 28 64 65 66 69 6e 65 igs data.(define
0a70: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 *configdat*
0a80: 23 66 29 20 20 20 3b 3b 20 6d 65 67 61 74 65 73 #f) ;; megates
0a90: 74 2e 63 6f 6e 66 69 67 20 64 61 74 61 0a 28 64 t.config data.(d
0aa0: 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 73 74 61 efine *configsta
0ab0: 74 75 73 2a 20 23 66 29 20 20 20 3b 3b 20 73 74 tus* #f) ;; st
0ac0: 61 74 75 73 20 6f 66 20 64 61 74 61 3b 20 27 66 atus of data; 'f
0ad0: 75 6c 6c 64 61 74 61 20 3a 20 61 6c 6c 20 70 72 ulldata : all pr
0ae0: 6f 63 65 73 73 69 6e 67 20 64 6f 6e 65 2c 20 23 ocessing done, #
0af0: 66 20 3a 20 6e 6f 20 64 61 74 61 20 79 65 74 2c f : no data yet,
0b00: 20 27 70 61 72 74 69 61 6c 64 61 74 61 20 3a 20 'partialdata :
0b10: 70 61 72 74 69 61 6c 20 72 65 61 64 20 64 6f 6e partial read don
0b20: 65 0a 28 64 65 66 69 6e 65 20 2a 74 6f 70 70 61 e.(define *toppa
0b30: 74 68 2a 20 20 20 20 20 20 23 66 29 0a 28 64 65 th* #f).(de
0b40: 66 69 6e 65 20 2a 61 6c 72 65 61 64 79 2d 73 65 fine *already-se
0b50: 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 en-runconfig-inf
0b60: 6f 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 o* #f)..(define
0b70: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
0b80: 65 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ed* (make-hash-t
0b90: 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a able)).(define *
0ba0: 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 globalexitstatus
0bb0: 2a 20 20 30 29 20 3b 3b 20 61 74 74 65 6d 70 74 * 0) ;; attempt
0bc0: 20 74 6f 20 77 6f 72 6b 20 61 72 6f 75 6e 64 20 to work around
0bd0: 70 6f 73 73 69 62 6c 65 20 74 68 72 65 61 64 20 possible thread
0be0: 69 73 73 75 65 73 0a 28 64 65 66 69 6e 65 20 2a issues.(define *
0bf0: 70 61 73 73 6e 75 6d 2a 20 20 20 20 20 20 20 20 passnum*
0c00: 20 20 20 30 29 20 3b 3b 20 77 68 65 6e 20 72 75 0) ;; when ru
0c10: 6e 6e 69 6e 67 20 74 72 61 63 6b 20 63 61 6c 6c nning track call
0c20: 73 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 6f s to run-tests o
0c30: 72 20 73 69 6d 69 6c 61 72 0a 3b 3b 20 28 64 65 r similar.;; (de
0c40: 66 69 6e 65 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 fine *alt-log-fi
0c50: 6c 65 2a 20 23 66 29 20 20 3b 3b 20 75 73 65 64 le* #f) ;; used
0c60: 20 62 79 20 2d 6c 6f 67 0a 28 64 65 66 69 6e 65 by -log.(define
0c70: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
0c80: 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d * (make-hash-
0c90: 74 61 62 6c 65 29 29 20 3b 3b 20 66 6f 72 20 6c table)) ;; for l
0ca0: 6f 77 20 6e 6f 69 73 65 20 70 72 69 6e 74 69 6e ow noise printin
0cb0: 67 0a 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 g.(define *defau
0cc0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 63 lt-log-port* (c
0cd0: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
0ce0: 74 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 65 66 t)).(define *def
0cf0: 61 75 6c 74 2d 61 72 65 61 2d 74 61 67 2a 20 22 ault-area-tag* "
0d00: 6c 6f 63 61 6c 22 29 0a 0a 3b 3b 20 44 41 54 41 local")..;; DATA
0d10: 42 41 53 45 0a 28 64 65 66 69 6e 65 20 2a 64 62 BASE.(define *db
0d20: 73 74 72 75 63 74 2d 64 62 2a 20 20 20 20 20 20 struct-db*
0d30: 20 20 20 23 66 29 20 3b 3b 20 75 73 65 64 20 74 #f) ;; used t
0d40: 6f 20 63 61 63 68 65 20 74 68 65 20 64 62 73 74 o cache the dbst
0d50: 72 75 63 74 20 69 6e 20 64 62 3a 73 65 74 75 70 ruct in db:setup
0d60: 2e 20 47 6f 61 6c 20 69 73 20 74 6f 20 72 65 6d . Goal is to rem
0d70: 6f 76 65 20 74 68 69 73 2e 0a 3b 3b 20 64 62 20 ove this..;; db
0d80: 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 2a access.(define *
0d90: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
0da0: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 (current-se
0db0: 63 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 74 20 conds)) ;; last
0dc0: 64 62 20 61 63 63 65 73 73 2c 20 75 73 65 64 20 db access, used
0dd0: 69 6e 20 73 65 72 76 65 72 0a 28 64 65 66 69 6e in server.(defin
0de0: 65 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 65 e *db-write-acce
0df0: 73 73 2a 20 20 20 20 20 23 74 29 0a 3b 3b 20 64 ss* #t).;; d
0e00: 62 20 73 79 6e 63 0a 28 64 65 66 69 6e 65 20 2a b sync.(define *
0e10: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 20 20 db-last-sync*
0e20: 20 20 20 20 20 30 29 20 20 20 20 20 20 20 20 20 0)
0e30: 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 ;; last
0e40: 74 69 6d 65 20 74 68 65 20 73 79 6e 63 20 74 6f time the sync to
0e50: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 68 61 70 megatest.db hap
0e60: 70 65 6e 65 64 0a 28 64 65 66 69 6e 65 20 2a 64 pened.(define *d
0e70: 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 b-sync-in-progre
0e80: 73 73 2a 20 23 66 29 20 20 20 20 20 20 20 20 20 ss* #f)
0e90: 20 20 20 20 20 20 20 3b 3b 20 69 66 20 74 68 65 ;; if the
0ea0: 72 65 20 69 73 20 61 20 73 79 6e 63 20 69 6e 20 re is a sync in
0eb0: 70 72 6f 67 72 65 73 73 20 64 6f 20 6e 6f 74 20 progress do not
0ec0: 74 72 79 20 74 6f 20 73 74 61 72 74 20 61 6e 6f try to start ano
0ed0: 74 68 65 72 0a 28 64 65 66 69 6e 65 20 2a 64 62 ther.(define *db
0ee0: 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 -multi-sync-mute
0ef0: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
0f00: 20 20 20 20 20 20 3b 3b 20 70 72 6f 74 65 63 74 ;; protect
0f10: 20 61 63 63 65 73 73 20 74 6f 20 2a 64 62 2d 73 access to *db-s
0f20: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
0f30: 2c 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a , *db-last-sync*
0f40: 0a 3b 3b 20 74 61 73 6b 20 64 62 0a 28 64 65 66 .;; task db.(def
0f50: 69 6e 65 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 ine *task-db*
0f60: 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b #f) ;;
0f70: 20 28 76 65 63 74 6f 72 20 64 62 20 70 61 74 68 (vector db path
0f80: 2d 74 6f 2d 64 62 29 0a 28 64 65 66 69 6e 65 20 -to-db).(define
0f90: 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 *db-access-allow
0fa0: 65 64 2a 20 20 20 23 74 29 20 3b 3b 20 66 6c 61 ed* #t) ;; fla
0fb0: 67 20 74 6f 20 61 6c 6c 6f 77 20 61 63 63 65 73 g to allow acces
0fc0: 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 s.(define *db-ac
0fd0: 63 65 73 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 cess-mutex*
0fe0: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 (make-mutex)).(d
0ff0: 65 66 69 6e 65 20 2a 64 62 2d 74 72 61 6e 73 61 efine *db-transa
1000: 63 74 69 6f 6e 2d 6d 75 74 65 78 2a 20 28 6d 61 ction-mutex* (ma
1010: 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 ke-mutex)).(defi
1020: 6e 65 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 ne *db-cache-pat
1030: 68 2a 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 h* #f).(de
1040: 66 69 6e 65 20 2a 64 62 2d 77 69 74 68 2d 64 62 fine *db-with-db
1050: 2d 6d 75 74 65 78 2a 20 20 20 20 28 6d 61 6b 65 -mutex* (make
1060: 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 -mutex)).(define
1070: 20 2a 64 62 2d 61 70 69 2d 63 61 6c 6c 2d 74 69 *db-api-call-ti
1080: 6d 65 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 me* (make-has
1090: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 61 73 h-table)) ;; has
10a0: 68 20 6f 66 20 63 6f 6d 6d 61 6e 64 20 3d 3e 20 h of command =>
10b0: 28 6c 69 73 74 20 6f 66 20 74 69 6d 65 73 29 0a (list of times).
10c0: 3b 3b 20 6e 6f 20 73 79 6e 63 20 64 62 0a 28 64 ;; no sync db.(d
10d0: 65 66 69 6e 65 20 2a 6e 6f 2d 73 79 6e 63 2d 64 efine *no-sync-d
10e0: 62 2a 20 20 20 20 20 20 20 20 20 20 23 66 29 0a b* #f).
10f0: 0a 3b 3b 20 53 45 52 56 45 52 0a 28 64 65 66 69 .;; SERVER.(defi
1100: 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 ne *my-client-si
1110: 67 6e 61 74 75 72 65 2a 20 23 66 29 0a 28 64 65 gnature* #f).(de
1120: 66 69 6e 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d fine *transport-
1130: 74 79 70 65 2a 20 20 20 20 27 68 74 74 70 29 20 type* 'http)
1140: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ;; o
1150: 76 65 72 72 69 64 65 20 77 69 74 68 20 5b 73 65 verride with [se
1160: 72 76 65 72 5d 20 74 72 61 6e 73 70 6f 72 74 20 rver] transport
1170: 68 74 74 70 7c 72 70 63 7c 6e 6d 73 67 0a 28 64 http|rpc|nmsg.(d
1180: 65 66 69 6e 65 20 2a 72 75 6e 72 65 6d 6f 74 65 efine *runremote
1190: 2a 20 20 20 20 20 20 20 20 20 23 66 29 20 20 20 * #f)
11a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
11b0: 69 66 20 73 65 74 20 75 70 20 66 6f 72 20 73 65 if set up for se
11c0: 72 76 65 72 20 63 6f 6d 6d 75 6e 69 63 61 74 69 rver communicati
11d0: 6f 6e 20 74 68 69 73 20 77 69 6c 6c 20 68 6f 6c on this will hol
11e0: 64 20 3c 68 6f 73 74 20 70 6f 72 74 3e 0a 3b 3b d <host port>.;;
11f0: 20 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 63 61 (define *max-ca
1200: 63 68 65 2d 73 69 7a 65 2a 20 20 20 20 30 29 0a che-size* 0).
1210: 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 65 64 2d (define *logged-
1220: 69 6e 2d 63 6c 69 65 6e 74 73 2a 20 28 6d 61 6b in-clients* (mak
1230: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 e-hash-table)).(
1240: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 define *server-i
1250: 64 2a 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 d* #f).(
1260: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 define *server-i
1270: 6e 66 6f 2a 20 20 20 20 20 20 20 23 66 29 20 20 nfo* #f)
1280: 3b 3b 20 67 6f 6f 64 20 63 61 6e 64 69 64 61 74 ;; good candidat
1290: 65 20 66 6f 72 20 65 61 73 69 6c 79 20 63 6f 6e e for easily con
12a0: 76 65 72 74 20 74 6f 20 6e 6f 6e 2d 67 6c 6f 62 vert to non-glob
12b0: 61 6c 0a 28 64 65 66 69 6e 65 20 2a 74 69 6d 65 al.(define *time
12c0: 2d 74 6f 2d 65 78 69 74 2a 20 20 20 20 20 20 23 -to-exit* #
12d0: 66 29 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 f).(define *serv
12e0: 65 72 2d 72 75 6e 2a 20 20 20 20 20 20 20 20 23 er-run* #
12f0: 74 29 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 2d t).(define *run-
1300: 69 64 2a 20 20 20 20 20 20 20 20 20 20 20 20 23 id* #
1310: 66 29 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 f).(define *serv
1320: 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 20 20 28 er-kind-run* (
1330: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
1340: 29 0a 28 64 65 66 69 6e 65 20 2a 68 6f 6d 65 2d ).(define *home-
1350: 68 6f 73 74 2a 20 20 20 20 20 20 20 20 20 23 66 host* #f
1360: 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a 74 6f ).;; (define *to
1370: 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 tal-non-write-de
1380: 6c 61 79 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 lay* 0).(define
1390: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
13a0: 2a 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 * (make-mutex)
13b0: 29 0a 28 64 65 66 69 6e 65 20 2a 61 70 69 2d 70 ).(define *api-p
13c0: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 rocess-request-c
13d0: 6f 75 6e 74 2a 20 30 29 0a 28 64 65 66 69 6e 65 ount* 0).(define
13e0: 20 2a 6d 61 78 2d 61 70 69 2d 70 72 6f 63 65 73 *max-api-proces
13f0: 73 2d 72 65 71 75 65 73 74 73 2a 20 30 29 0a 28 s-requests* 0).(
1400: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 6f define *server-o
1410: 76 65 72 6c 6f 61 64 65 64 2a 20 20 23 66 29 0a verloaded* #f).
1420: 0a 3b 3b 20 63 6c 69 65 6e 74 0a 28 64 65 66 69 .;; client.(defi
1430: 6e 65 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 20 20 ne *rmt-mutex*
1440: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 (make-mut
1450: 65 78 29 29 20 20 20 20 20 3b 3b 20 72 65 6d 6f ex)) ;; remo
1460: 74 65 20 61 63 63 65 73 73 20 63 61 6c 6c 73 20 te access calls
1470: 6d 75 74 65 78 20 0a 0a 3b 3b 20 52 50 43 20 74 mutex ..;; RPC t
1480: 72 61 6e 73 70 6f 72 74 0a 28 64 65 66 69 6e 65 ransport.(define
1490: 20 2a 72 70 63 3a 6c 69 73 74 65 6e 65 72 2a 20 *rpc:listener*
14a0: 20 20 20 20 20 23 66 29 0a 0a 3b 3b 20 4b 45 59 #f)..;; KEY
14b0: 20 69 6e 66 6f 0a 28 64 65 66 69 6e 65 20 2a 74 info.(define *t
14c0: 61 72 67 65 74 2a 20 20 20 20 20 20 20 20 20 20 arget*
14d0: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
14e0: 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 68 le)) ;; cache th
14f0: 65 20 74 61 72 67 65 74 20 68 65 72 65 3b 20 74 e target here; t
1500: 61 72 67 65 74 20 69 73 20 6b 65 79 76 61 6c 31 arget is keyval1
1510: 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e 2f 6b 65 79 /keyval2/.../key
1520: 76 61 6c 4e 0a 28 64 65 66 69 6e 65 20 2a 6b 65 valN.(define *ke
1530: 79 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 ys*
1540: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1550: 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 68 65 e)) ;; cache the
1560: 20 6b 65 79 73 20 68 65 72 65 0a 28 64 65 66 69 keys here.(defi
1570: 6e 65 20 2a 6b 65 79 76 61 6c 73 2a 20 20 20 20 ne *keyvals*
1580: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
1590: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
15a0: 65 20 2a 74 6f 70 74 65 73 74 2d 70 61 74 68 73 e *toptest-paths
15b0: 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 * (make-hash
15c0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
15d0: 65 20 74 6f 70 74 65 73 74 20 70 61 74 68 20 73 e toptest path s
15e0: 65 74 74 69 6e 67 73 20 68 65 72 65 0a 28 64 65 ettings here.(de
15f0: 66 69 6e 65 20 2a 74 65 73 74 2d 70 61 74 68 73 fine *test-paths
1600: 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 * (make-h
1610: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 ash-table)) ;; c
1620: 61 63 68 65 20 74 65 73 74 2d 69 64 20 74 6f 20 ache test-id to
1630: 74 65 73 74 20 72 75 6e 20 70 61 74 68 73 20 68 test run paths h
1640: 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 ere.(define *tes
1650: 74 2d 69 64 73 2a 20 20 20 20 20 20 20 20 20 20 t-ids*
1660: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1670: 29 29 20 3b 3b 20 63 61 63 68 65 20 72 75 6e 2d )) ;; cache run-
1680: 69 64 2c 20 74 65 73 74 6e 61 6d 65 2c 20 61 6e id, testname, an
1690: 64 20 69 74 65 6d 2d 70 61 74 68 20 3d 3e 20 74 d item-path => t
16a0: 65 73 74 2d 69 64 0a 28 64 65 66 69 6e 65 20 2a est-id.(define *
16b0: 74 65 73 74 2d 69 6e 66 6f 2a 20 20 20 20 20 20 test-info*
16c0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
16d0: 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 ble)) ;; cache t
16e0: 68 65 20 74 65 73 74 20 69 6e 66 6f 20 72 65 63 he test info rec
16f0: 6f 72 64 73 2c 20 75 70 64 61 74 65 20 74 68 65 ords, update the
1700: 20 73 74 61 74 65 2c 20 73 74 61 74 75 73 2c 20 state, status,
1710: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 65 74 63 run_duration etc
1720: 2e 20 66 72 6f 6d 20 74 65 73 74 64 61 74 2e 64 . from testdat.d
1730: 62 0a 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 2d b..(define *run-
1740: 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 20 20 20 info-cache*
1750: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1760: 29 29 20 3b 3b 20 72 75 6e 20 69 6e 66 6f 20 69 )) ;; run info i
1770: 73 20 73 74 61 62 6c 65 2c 20 6e 6f 20 6e 65 65 s stable, no nee
1780: 64 20 74 6f 20 72 65 67 65 74 0a 28 64 65 66 69 d to reget.(defi
1790: 6e 65 20 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 ne *launch-setup
17a0: 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 -mutex* (make-mu
17b0: 74 65 78 29 29 20 20 20 20 20 3b 3b 20 6e 65 65 tex)) ;; nee
17c0: 64 20 74 6f 20 62 65 20 61 62 6c 65 20 74 6f 20 d to be able to
17d0: 63 61 6c 6c 20 6c 61 75 6e 63 68 3a 73 65 74 75 call launch:setu
17e0: 70 20 6f 66 74 65 6e 20 73 6f 20 6d 75 74 65 78 p often so mutex
17f0: 20 69 74 20 61 6e 64 20 72 65 2d 63 61 6c 6c 20 it and re-call
1800: 74 68 65 20 72 65 61 6c 20 64 65 61 6c 20 6f 6e the real deal on
1810: 6c 79 20 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 ly if *toppath*
1820: 6e 6f 74 20 73 65 74 0a 28 64 65 66 69 6e 65 20 not set.(define
1830: 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a *homehost-mutex*
1840: 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 (make-mutex
1850: 29 29 0a 0a 3b 3b 20 4d 69 73 63 65 6c 6c 61 6e ))..;; Miscellan
1860: 65 6f 75 73 0a 28 64 65 66 69 6e 65 20 2a 74 72 eous.(define *tr
1870: 69 67 67 65 72 73 2d 6d 75 74 65 78 2a 20 20 20 iggers-mutex*
1880: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 (make-mutex))
1890: 20 20 20 20 3b 3b 20 62 6c 6f 63 6b 20 6f 76 65 ;; block ove
18a0: 72 6c 61 70 70 69 6e 67 20 70 72 6f 63 65 73 73 rlapping process
18b0: 69 6e 67 20 6f 66 20 74 72 69 67 67 65 72 73 0a ing of triggers.
18c0: 0a 3b 3b 20 74 68 69 73 20 77 61 73 20 63 61 63 .;; this was cac
18d0: 68 65 64 20 62 61 73 65 64 20 6f 6e 20 72 65 73 hed based on res
18e0: 75 6c 74 73 20 66 72 6f 6d 20 70 72 6f 66 69 6c ults from profil
18f0: 69 6e 67 20 62 75 74 20 69 74 20 74 75 72 6e 65 ing but it turne
1900: 64 20 6f 75 74 20 74 68 65 20 70 72 6f 66 69 6c d out the profil
1910: 69 6e 67 0a 3b 3b 20 73 6f 6d 65 68 6f 77 20 77 ing.;; somehow w
1920: 65 6e 74 20 77 72 6f 6e 67 20 2d 20 70 65 72 68 ent wrong - perh
1930: 61 70 73 20 74 6f 6f 20 6d 61 6e 79 20 70 72 6f aps too many pro
1940: 63 65 73 73 65 73 20 77 72 69 74 69 6e 67 20 74 cesses writing t
1950: 6f 20 69 74 2e 20 4c 65 61 76 69 6e 67 20 74 68 o it. Leaving th
1960: 65 20 63 61 63 68 69 6e 67 0a 3b 3b 20 69 6e 20 e caching.;; in
1970: 66 6f 72 20 6e 6f 77 20 62 75 74 20 63 61 6e 20 for now but can
1980: 70 72 6f 62 61 62 6c 79 20 74 61 6b 65 20 69 74 probably take it
1990: 20 6f 75 74 20 6c 61 74 65 72 2e 0a 3b 3b 0a 28 out later..;;.(
19a0: 64 65 66 69 6e 65 20 28 64 65 62 75 67 3a 63 61 define (debug:ca
19b0: 6c 63 2d 76 65 72 62 6f 73 69 74 79 20 76 73 74 lc-verbosity vst
19c0: 72 20 76 65 72 62 6f 73 65 20 71 75 69 65 74 29 r verbose quiet)
19d0: 20 3b 3b 20 76 65 72 62 6f 73 65 20 61 6e 64 20 ;; verbose and
19e0: 71 75 69 65 74 20 61 72 65 20 23 66 20 6f 72 20 quiet are #f or
19f0: 65 6e 61 62 6c 65 64 0a 20 20 28 6f 72 20 28 68 enabled. (or (h
1a00: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1a10: 66 61 75 6c 74 20 2a 76 65 72 62 6f 73 69 74 79 fault *verbosity
1a20: 2d 63 61 63 68 65 2a 20 76 73 74 72 20 23 66 29 -cache* vstr #f)
1a30: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
1a40: 73 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 s (cond.
1a50: 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 6d 62 ((numb
1a60: 65 72 3f 20 76 73 74 72 29 20 76 73 74 72 29 0a er? vstr) vstr).
1a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a80: 20 20 28 28 6e 6f 74 20 28 73 74 72 69 6e 67 3f ((not (string?
1a90: 20 20 76 73 74 72 29 29 20 20 20 31 29 0a 20 20 vstr)) 1).
1aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ab0: 3b 3b 20 28 28 73 74 72 69 6e 67 2d 6d 61 74 63 ;; ((string-matc
1ac0: 68 20 20 22 5e 5c 5c 73 2a 24 22 20 76 73 74 72 h "^\\s*$" vstr
1ad0: 29 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 ) 1).
1ae0: 20 20 20 20 20 20 20 28 76 73 74 72 20 20 20 20 (vstr
1af0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 65 (let ((de
1b00: 62 75 67 76 61 6c 73 20 20 28 66 69 6c 74 65 72 bugvals (filter
1b10: 20 6e 75 6d 62 65 72 3f 20 28 6d 61 70 20 73 74 number? (map st
1b20: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 73 74 ring->number (st
1b30: 72 69 6e 67 2d 73 70 6c 69 74 20 76 73 74 72 20 ring-split vstr
1b40: 22 2c 22 29 29 29 29 29 0a 20 20 20 20 20 20 20 ","))))).
1b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
1b70: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
1b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b90: 20 20 20 20 20 20 20 20 28 28 3e 20 28 6c 65 6e ((> (len
1ba0: 67 74 68 20 64 65 62 75 67 76 61 6c 73 29 20 31 gth debugvals) 1
1bb0: 29 20 64 65 62 75 67 76 61 6c 73 29 0a 20 20 20 ) debugvals).
1bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1be0: 20 20 28 28 3e 20 28 6c 65 6e 67 74 68 20 64 65 ((> (length de
1bf0: 62 75 67 76 61 6c 73 29 20 30 29 28 63 61 72 20 bugvals) 0)(car
1c00: 64 65 62 75 67 76 61 6c 73 29 29 0a 20 20 20 20 debugvals)).
1c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c30: 20 28 65 6c 73 65 20 31 29 29 29 29 0a 20 20 20 (else 1)))).
1c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1c50: 76 65 72 62 6f 73 65 20 20 20 20 20 20 20 20 20 verbose
1c60: 20 20 20 20 20 20 20 32 29 20 3b 3b 20 28 28 61 2) ;; ((a
1c70: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 76 22 rgs:get-arg "-v"
1c80: 29 20 20 20 32 29 0a 20 20 20 20 20 20 20 20 20 ) 2).
1c90: 20 20 20 20 20 20 20 20 20 28 71 75 69 65 74 20 (quiet
1ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cb0: 20 30 29 20 3b 3b 20 28 28 61 72 67 73 3a 67 65 0) ;; ((args:ge
1cc0: 74 2d 61 72 67 20 22 2d 71 22 29 20 20 20 20 30 t-arg "-q") 0
1cd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1ce0: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
1cf0: 20 20 20 20 20 20 20 20 20 20 20 20 31 29 29 29 1)))
1d00: 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ). (hash-
1d10: 74 61 62 6c 65 2d 73 65 74 21 20 2a 76 65 72 62 table-set! *verb
1d20: 6f 73 69 74 79 2d 63 61 63 68 65 2a 20 76 73 74 osity-cache* vst
1d30: 72 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 r res). r
1d40: 65 73 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 es)))..;; check
1d50: 76 65 72 62 6f 73 69 74 79 2c 20 23 74 20 69 73 verbosity, #t is
1d60: 20 6f 6b 0a 28 64 65 66 69 6e 65 20 28 64 65 62 ok.(define (deb
1d70: 75 67 3a 63 68 65 63 6b 2d 76 65 72 62 6f 73 69 ug:check-verbosi
1d80: 74 79 20 76 65 72 62 6f 73 69 74 79 20 76 73 74 ty verbosity vst
1d90: 72 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 6f r). (if (not (o
1da0: 72 20 28 6e 75 6d 62 65 72 3f 20 76 65 72 62 6f r (number? verbo
1db0: 73 69 74 79 29 0a 09 20 20 20 20 20 20 20 28 6c sity).. (l
1dc0: 69 73 74 3f 20 20 20 76 65 72 62 6f 73 69 74 79 ist? verbosity
1dd0: 29 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e ))). (begin
1de0: 0a 09 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a ..(print "ERROR:
1df0: 20 49 6e 76 61 6c 69 64 20 64 65 62 75 67 20 76 Invalid debug v
1e00: 61 6c 75 65 20 5c 22 22 20 76 73 74 72 20 22 5c alue \"" vstr "\
1e10: 22 22 29 0a 09 23 66 29 0a 20 20 20 20 20 20 23 "")..#f). #
1e20: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 t))..(define (de
1e30: 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 6e bug:debug-mode n
1e40: 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 61 ). (cond. ((a
1e50: 6e 64 20 28 6e 75 6d 62 65 72 3f 20 2a 76 65 72 nd (number? *ver
1e60: 62 6f 73 69 74 79 2a 29 20 20 20 3b 3b 20 6e 75 bosity*) ;; nu
1e70: 6d 62 65 72 20 6e 75 6d 62 65 72 0a 09 20 28 6e mber number.. (n
1e80: 75 6d 62 65 72 3f 20 6e 29 29 0a 20 20 20 20 28 umber? n)). (
1e90: 3c 3d 20 6e 20 2a 76 65 72 62 6f 73 69 74 79 2a <= n *verbosity*
1ea0: 29 29 0a 20 20 20 28 28 61 6e 64 20 28 6c 69 73 )). ((and (lis
1eb0: 74 3f 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 t? *verbosity*)
1ec0: 20 20 20 20 3b 3b 20 6c 69 73 74 20 20 20 6e 75 ;; list nu
1ed0: 6d 62 65 72 0a 09 20 28 6e 75 6d 62 65 72 3f 20 mber.. (number?
1ee0: 6e 29 29 0a 20 20 20 20 28 6d 65 6d 62 65 72 20 n)). (member
1ef0: 6e 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 29 0a n *verbosity*)).
1f00: 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 ((and (list?
1f10: 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 20 20 20 *verbosity*)
1f20: 20 3b 3b 20 6c 69 73 74 20 20 20 6c 69 73 74 0a ;; list list.
1f30: 09 20 28 6c 69 73 74 3f 20 6e 29 29 0a 20 20 20 . (list? n)).
1f40: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 6c 73 (not (null? (ls
1f50: 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 et-intersection!
1f60: 20 65 71 3f 20 2a 76 65 72 62 6f 73 69 74 79 2a eq? *verbosity*
1f70: 20 6e 29 29 29 29 0a 20 20 20 28 28 61 6e 64 20 n)))). ((and
1f80: 28 6e 75 6d 62 65 72 3f 20 2a 76 65 72 62 6f 73 (number? *verbos
1f90: 69 74 79 2a 29 0a 09 20 28 6c 69 73 74 3f 20 6e ity*).. (list? n
1fa0: 29 29 0a 20 20 20 20 28 6d 65 6d 62 65 72 20 2a )). (member *
1fb0: 76 65 72 62 6f 73 69 74 79 2a 20 6e 29 29 29 29 verbosity* n))))
1fc0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 62 75 67 ..(define (debug
1fd0: 3a 73 65 74 75 70 20 64 6d 6f 64 65 20 76 65 72 :setup dmode ver
1fe0: 62 6f 73 65 20 71 75 69 65 74 29 0a 20 20 28 6c bose quiet). (l
1ff0: 65 74 20 28 28 64 65 62 75 67 73 74 72 20 28 6f et ((debugstr (o
2000: 72 20 64 6d 6f 64 65 20 20 20 20 20 20 20 20 20 r dmode
2010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2020: 20 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 ;; (args:get-a
2030: 72 67 20 22 2d 64 65 62 75 67 22 29 0a 09 09 20 rg "-debug")...
2040: 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
2050: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
2060: 4d 54 5f 44 45 42 55 47 5f 4d 4f 44 45 22 29 29 MT_DEBUG_MODE"))
2070: 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 76 65 )). (set! *ve
2080: 72 62 6f 73 69 74 79 2a 20 28 64 65 62 75 67 3a rbosity* (debug:
2090: 63 61 6c 63 2d 76 65 72 62 6f 73 69 74 79 20 64 calc-verbosity d
20a0: 65 62 75 67 73 74 72 20 76 65 72 62 6f 73 65 20 ebugstr verbose
20b0: 71 75 69 65 74 29 29 0a 20 20 20 20 28 64 65 62 quiet)). (deb
20c0: 75 67 3a 63 68 65 63 6b 2d 76 65 72 62 6f 73 69 ug:check-verbosi
20d0: 74 79 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 64 ty *verbosity* d
20e0: 65 62 75 67 73 74 72 29 0a 20 20 20 20 3b 3b 20 ebugstr). ;;
20f0: 69 66 20 77 65 20 77 65 72 65 20 68 61 6e 64 65 if we were hande
2100: 64 20 61 20 62 61 64 20 76 65 72 62 6f 73 69 74 d a bad verbosit
2110: 79 20 72 75 6c 65 20 74 68 65 6e 20 77 65 20 77 y rule then we w
2120: 69 6c 6c 20 6f 76 65 72 72 69 64 65 20 69 74 20 ill override it
2130: 77 69 74 68 20 31 20 61 6e 64 20 63 6f 6e 74 69 with 1 and conti
2140: 6e 75 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 nue. (if (not
2150: 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 28 73 65 *verbosity*)(se
2160: 74 21 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 t! *verbosity* 1
2170: 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 64 )). (if (or d
2180: 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 20 20 mode
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21b0: 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ;; (args:get-arg
21c0: 20 22 2d 64 65 62 75 67 22 29 0a 09 20 20 20 20 "-debug")..
21d0: 28 6e 6f 74 20 28 67 65 74 2d 65 6e 76 69 72 6f (not (get-enviro
21e0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
21f0: 4d 54 5f 44 45 42 55 47 5f 4d 4f 44 45 22 29 29 MT_DEBUG_MODE"))
2200: 29 0a 09 28 73 65 74 65 6e 76 20 22 4d 54 5f 44 )..(setenv "MT_D
2210: 45 42 55 47 5f 4d 4f 44 45 22 20 28 69 66 20 28 EBUG_MODE" (if (
2220: 6c 69 73 74 3f 20 2a 76 65 72 62 6f 73 69 74 79 list? *verbosity
2230: 2a 29 0a 09 09 09 09 20 20 20 20 28 73 74 72 69 *)..... (stri
2240: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
2250: 6d 61 70 20 63 6f 6e 63 20 2a 76 65 72 62 6f 73 map conc *verbos
2260: 69 74 79 2a 29 20 22 2c 22 29 0a 09 09 09 09 20 ity*) ",").....
2270: 20 20 20 28 63 6f 6e 63 20 2a 76 65 72 62 6f 73 (conc *verbos
2280: 69 74 79 2a 29 29 29 29 29 29 0a 20 20 0a 28 64 ity*)))))). .(d
2290: 65 66 69 6e 65 20 28 64 65 62 75 67 3a 70 72 69 efine (debug:pri
22a0: 6e 74 20 6e 20 65 20 2e 20 70 61 72 61 6d 73 29 nt n e . params)
22b0: 0a 20 20 28 69 66 20 28 64 65 62 75 67 3a 64 65 . (if (debug:de
22c0: 62 75 67 2d 6d 6f 64 65 20 6e 29 0a 20 20 20 20 bug-mode n).
22d0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
22e0: 6f 2d 70 6f 72 74 20 28 6f 72 20 65 20 28 63 75 o-port (or e (cu
22f0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
2300: 29 29 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 ))..(lambda ()..
2310: 20 20 3b 3b 20 28 69 66 20 2a 6c 6f 67 67 69 6e ;; (if *loggin
2320: 67 2a 0a 09 20 20 3b 3b 20 20 20 20 28 65 78 65 g*.. ;; (exe
2330: 63 2d 66 6e 20 27 64 62 3a 6c 6f 67 2d 65 76 65 c-fn 'db:log-eve
2340: 6e 74 20 28 61 70 70 6c 79 20 63 6f 6e 63 20 70 nt (apply conc p
2350: 61 72 61 6d 73 29 29 0a 09 20 20 28 61 70 70 6c arams)).. (appl
2360: 79 20 70 72 69 6e 74 20 70 61 72 61 6d 73 29 0a y print params).
2370: 09 20 20 29 29 29 29 20 3b 3b 20 29 0a 0a 28 64 . )))) ;; )..(d
2380: 65 66 69 6e 65 20 28 64 65 62 75 67 3a 70 72 69 efine (debug:pri
2390: 6e 74 2d 65 72 72 6f 72 20 6e 20 65 20 2e 20 70 nt-error n e . p
23a0: 61 72 61 6d 73 29 0a 20 20 3b 3b 20 6e 6f 72 6d arams). ;; norm
23b0: 61 6c 20 70 72 69 6e 74 0a 20 20 28 69 66 20 28 al print. (if (
23c0: 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 debug:debug-mode
23d0: 20 6e 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d n). (with-
23e0: 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 output-to-port (
23f0: 69 66 20 28 70 6f 72 74 3f 20 65 29 20 65 20 28 if (port? e) e (
2400: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
2410: 72 74 29 29 0a 09 28 6c 61 6d 62 64 61 20 28 29 rt))..(lambda ()
2420: 0a 09 20 20 3b 3b 20 28 69 66 20 2a 6c 6f 67 67 .. ;; (if *logg
2430: 69 6e 67 2a 0a 09 20 20 20 20 20 3b 3b 20 28 65 ing*.. ;; (e
2440: 78 65 63 2d 66 6e 20 27 64 62 3a 6c 6f 67 2d 65 xec-fn 'db:log-e
2450: 76 65 6e 74 20 28 61 70 70 6c 79 20 63 6f 6e 63 vent (apply conc
2460: 20 70 61 72 61 6d 73 29 29 0a 09 20 20 20 20 20 params))..
2470: 20 3b 3b 20 28 61 70 70 6c 79 20 70 72 69 6e 74 ;; (apply print
2480: 20 22 70 69 64 3a 22 20 28 63 75 72 72 65 6e 74 "pid:" (current
2490: 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 20 22 -process-id) " "
24a0: 20 70 61 72 61 6d 73 29 0a 09 20 20 28 61 70 70 params).. (app
24b0: 6c 79 20 70 72 69 6e 74 20 22 45 52 52 4f 52 3a ly print "ERROR:
24c0: 20 22 20 70 61 72 61 6d 73 29 0a 09 20 20 29 29 " params).. ))
24d0: 29 20 3b 3b 20 29 0a 20 20 3b 3b 20 70 61 73 73 ) ;; ). ;; pass
24e0: 20 69 6d 70 6f 72 74 61 6e 74 20 6d 65 73 73 61 important messa
24f0: 67 65 73 20 74 6f 20 73 74 64 65 72 72 0a 20 20 ges to stderr.
2500: 28 69 66 20 28 61 6e 64 20 28 65 71 3f 20 6e 20 (if (and (eq? n
2510: 30 29 28 6e 6f 74 20 28 65 71 3f 20 65 20 28 63 0)(not (eq? e (c
2520: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
2530: 74 29 29 29 29 20 0a 20 20 20 20 20 20 28 77 69 t)))) . (wi
2540: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
2550: 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 t (current-error
2560: 2d 70 6f 72 74 29 0a 09 28 6c 61 6d 62 64 61 20 -port)..(lambda
2570: 28 29 0a 09 20 20 28 61 70 70 6c 79 20 70 72 69 ().. (apply pri
2580: 6e 74 20 22 45 52 52 4f 52 3a 20 22 20 70 61 72 nt "ERROR: " par
2590: 61 6d 73 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 ams).. ))))..(d
25a0: 65 66 69 6e 65 20 28 64 65 62 75 67 3a 70 72 69 efine (debug:pri
25b0: 6e 74 2d 69 6e 66 6f 20 6e 20 65 20 2e 20 70 61 nt-info n e . pa
25c0: 72 61 6d 73 29 0a 20 20 28 69 66 20 28 64 65 62 rams). (if (deb
25d0: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 6e 29 ug:debug-mode n)
25e0: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 . (with-out
25f0: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 69 66 20 put-to-port (if
2600: 28 70 6f 72 74 3f 20 65 29 20 65 20 28 63 75 72 (port? e) e (cur
2610: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
2620: 29 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 )..(lambda ()..
2630: 20 3b 3b 20 28 69 66 20 2a 6c 6f 67 67 69 6e 67 ;; (if *logging
2640: 2a 0a 09 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 *.. ;; (let
2650: 28 28 72 65 73 20 28 66 6f 72 6d 61 74 23 66 6f ((res (format#fo
2660: 72 6d 61 74 20 23 66 20 22 49 4e 46 4f 3a 20 28 rmat #f "INFO: (
2670: 7e 61 29 20 7e 61 22 20 6e 20 28 61 70 70 6c 79 ~a) ~a" n (apply
2680: 20 63 6f 6e 63 20 70 61 72 61 6d 73 29 29 29 29 conc params))))
2690: 0a 09 09 3b 3b 20 28 65 78 65 63 2d 66 6e 20 27 ...;; (exec-fn '
26a0: 64 62 3a 6c 6f 67 2d 65 76 65 6e 74 20 72 65 73 db:log-event res
26b0: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 61 70 )).. ;; (ap
26c0: 70 6c 79 20 70 72 69 6e 74 20 22 70 69 64 3a 22 ply print "pid:"
26d0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
26e0: 73 2d 69 64 29 20 22 20 22 20 22 49 4e 46 4f 3a s-id) " " "INFO:
26f0: 20 28 22 20 6e 20 22 29 20 22 20 70 61 72 61 6d (" n ") " param
2700: 73 29 20 3b 3b 20 72 65 73 29 0a 09 20 20 28 61 s) ;; res).. (a
2710: 70 70 6c 79 20 70 72 69 6e 74 20 22 49 4e 46 4f pply print "INFO
2720: 3a 20 28 22 20 6e 20 22 29 20 22 20 70 61 72 61 : (" n ") " para
2730: 6d 73 29 20 3b 3b 20 72 65 73 29 0a 09 20 20 29 ms) ;; res).. )
2740: 29 29 29 20 3b 3b 20 29 0a 0a 3b 3b 20 4c 6f 6f ))) ;; )..;; Loo
2750: 6b 75 70 20 61 20 76 61 6c 75 65 20 69 6e 20 72 kup a value in r
2760: 75 6e 63 6f 6e 66 69 67 73 20 62 61 73 65 64 20 unconfigs based
2770: 6f 6e 20 2d 72 65 71 74 61 72 67 20 6f 72 20 2d on -reqtarg or -
2780: 74 61 72 67 65 74 0a 3b 3b 20 0a 28 64 65 66 69 target.;; .(defi
2790: 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 ne (runconfigs-g
27a0: 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 0a 20 et config var).
27b0: 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 63 6f (let ((targ (co
27c0: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 mmon:args-get-ta
27d0: 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 28 rget))) ;; (or (
27e0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
27f0: 65 71 74 61 72 67 22 29 28 61 72 67 73 3a 67 65 eqtarg")(args:ge
2800: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
2810: 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 (getenv "MT_TARG
2820: 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 ET")))). (if
2830: 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 69 targ..(or (confi
2840: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
2850: 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 20 20 targ var)..
2860: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
2870: 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 config "default"
2880: 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 66 var))..(configf
2890: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
28a0: 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 29 29 default" var))))
28b0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
28c0: 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 65 n:args-get-state
28d0: 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 ). (or (args:ge
28e0: 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 28 t-arg "-state")(
28f0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
2900: 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 69 6e tate")))..(defin
2910: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
2920: 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 6f 72 et-status). (or
2930: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
2940: 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 3a 67 -status")(args:g
2950: 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 et-arg ":status"
2960: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
2970: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 65 mmon:args-get-te
2980: 73 74 70 61 74 74 20 72 63 6f 6e 66 29 0a 20 20 stpatt rconf).
2990: 28 6c 65 74 2a 20 28 3b 3b 20 28 74 61 67 65 78 (let* (;; (tagex
29a0: 70 72 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 pr (args:g
29b0: 65 74 2d 61 72 67 20 22 2d 74 61 67 65 78 70 72 et-arg "-tagexpr
29c0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 ")). ;;
29d0: 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 20 28 (tags-testpatt (
29e0: 69 66 20 74 61 67 65 78 70 72 20 28 73 74 72 69 if tagexpr (stri
29f0: 6e 67 2d 6a 6f 69 6e 20 28 72 75 6e 73 3a 67 65 ng-join (runs:ge
2a00: 74 2d 74 65 73 74 73 2d 6d 61 74 63 68 69 6e 67 t-tests-matching
2a10: 2d 74 61 67 73 20 74 61 67 65 78 70 72 29 20 22 -tags tagexpr) "
2a20: 2c 22 29 20 23 66 29 29 0a 20 20 20 20 20 20 20 ,") #f)).
2a30: 20 20 28 74 65 73 74 70 61 74 74 2d 6b 65 79 20 (testpatt-key
2a40: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
2a50: 72 67 20 22 2d 6d 6f 64 65 70 61 74 74 22 29 20 rg "-modepatt")
2a60: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
2a70: 2d 6d 6f 64 65 70 61 74 74 22 29 20 22 54 45 53 -modepatt") "TES
2a80: 54 50 41 54 54 22 29 29 0a 20 20 20 20 20 20 20 TPATT")).
2a90: 20 20 28 61 72 67 73 2d 74 65 73 74 70 61 74 74 (args-testpatt
2aa0: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
2ab0: 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 20 rg "-testpatt")
2ac0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
2ad0: 72 75 6e 74 65 73 74 73 22 29 20 22 25 22 29 29 runtests") "%"))
2ae0: 0a 20 20 20 20 20 20 20 20 20 28 72 74 65 73 74 . (rtest
2af0: 70 61 74 74 20 20 20 20 20 28 69 66 20 72 63 6f patt (if rco
2b00: 6e 66 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 nf (runconfigs-g
2b10: 65 74 20 72 63 6f 6e 66 20 74 65 73 74 70 61 74 et rconf testpat
2b20: 74 2d 6b 65 79 29 20 23 66 29 29 29 0a 20 20 20 t-key) #f))).
2b30: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6f 72 (cond. ((or
2b40: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
2b50: 2d 2d 6d 6f 64 65 70 61 74 74 22 29 20 28 61 72 --modepatt") (ar
2b60: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 6f 64 gs:get-arg "-mod
2b70: 65 70 61 74 74 22 29 29 20 3b 3b 20 6d 6f 64 65 epatt")) ;; mode
2b80: 70 61 74 74 20 69 73 20 61 20 66 6f 72 63 65 64 patt is a forced
2b90: 20 73 65 74 74 69 6e 67 2c 20 77 68 65 6e 20 73 setting, when s
2ba0: 65 74 20 69 74 20 4d 55 53 54 20 72 65 66 65 72 et it MUST refer
2bb0: 20 74 6f 20 61 6e 20 65 78 69 73 74 69 6e 67 20 to an existing
2bc0: 50 41 54 54 20 69 6e 20 74 68 65 20 72 75 6e 63 PATT in the runc
2bd0: 6f 6e 66 69 67 0a 20 20 20 20 20 20 28 69 66 20 onfig. (if
2be0: 72 63 6f 6e 66 0a 09 20 20 28 6c 65 74 2a 20 28 rconf.. (let* (
2bf0: 28 70 61 74 74 73 2d 66 72 6f 6d 2d 6d 6f 64 65 (patts-from-mode
2c00: 2d 70 61 74 74 09 20 20 28 72 75 6e 63 6f 6e 66 -patt. (runconf
2c10: 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 74 65 igs-get rconf te
2c20: 73 74 70 61 74 74 2d 6b 65 79 29 29 29 0a 09 20 stpatt-key)))..
2c30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2c40: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
2c50: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d 6f 64 65 70 log-port* "modep
2c60: 61 74 74 20 64 65 66 69 6e 65 64 20 69 73 3a 20 att defined is:
2c70: 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 72 "testpatt-key" r
2c80: 75 6e 63 6f 6e 66 69 67 73 20 76 61 6c 75 65 73 unconfigs values
2c90: 20 66 6f 72 20 20 22 20 74 65 73 74 70 61 74 74 for " testpatt
2ca0: 2d 6b 65 79 20 22 20 22 20 20 70 61 74 74 73 2d -key " " patts-
2cb0: 66 72 6f 6d 2d 6d 6f 64 65 2d 70 61 74 74 29 0a from-mode-patt).
2cc0: 09 20 20 20 20 70 61 74 74 73 2d 66 72 6f 6d 2d . patts-from-
2cd0: 6d 6f 64 65 2d 70 61 74 74 29 0a 09 20 20 28 62 mode-patt).. (b
2ce0: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 egin.. (debug
2cf0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
2d00: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2d10: 20 22 20 6d 6f 64 65 70 61 74 74 20 64 65 66 69 " modepatt defi
2d20: 6e 65 64 20 69 73 3a 20 22 74 65 73 74 70 61 74 ned is: "testpat
2d30: 74 2d 6b 65 79 22 20 72 75 6e 63 6f 6e 66 69 67 t-key" runconfig
2d40: 73 20 76 61 6c 75 65 73 20 66 6f 72 20 20 22 20 s values for "
2d50: 74 65 73 74 70 61 74 74 2d 6b 65 79 29 20 3b 3b testpatt-key) ;;
2d60: 20 20 22 20 22 20 70 61 74 74 73 2d 66 72 6f 6d " " patts-from
2d70: 2d 6d 6f 64 65 2d 70 61 74 74 29 0a 09 20 20 20 -mode-patt)..
2d80: 20 23 66 29 29 29 20 20 20 20 20 3b 3b 20 57 65 #f))) ;; We
2d90: 20 64 6f 20 4e 4f 54 20 66 61 6c 6c 20 62 61 63 do NOT fall bac
2da0: 6b 20 74 6f 20 22 25 22 0a 20 20 20 20 20 3b 3b k to "%". ;;
2db0: 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 0a (tags-testpatt.
2dc0: 20 20 20 20 20 3b 3b 20 20 28 64 65 62 75 67 3a ;; (debug:
2dd0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
2de0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2df0: 22 2d 74 61 67 65 78 70 72 20 22 74 61 67 65 78 "-tagexpr "tagex
2e00: 70 72 22 20 73 65 6c 65 63 74 73 20 74 65 73 74 pr" selects test
2e10: 70 61 74 74 20 22 74 61 67 73 2d 74 65 73 74 70 patt "tags-testp
2e20: 61 74 74 29 0a 20 20 20 20 20 3b 3b 20 20 74 61 att). ;; ta
2e30: 67 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 20 gs-testpatt).
2e40: 20 20 28 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 ((and (equal?
2e50: 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 args-testpatt "%
2e60: 22 29 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 ") rtestpatt).
2e70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2e80: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
2e90: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
2ea0: 70 61 74 74 20 64 65 66 69 6e 65 64 20 69 6e 20 patt defined in
2eb0: 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 66 "testpatt-key" f
2ec0: 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a 20 rom runconfigs:
2ed0: 22 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 20 " rtestpatt).
2ee0: 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 rtestpatt).
2ef0: 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 20 (else .
2f00: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2f10: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2f20: 2d 70 6f 72 74 2a 20 22 75 73 69 6e 67 20 74 65 -port* "using te
2f30: 73 74 70 61 74 74 20 22 20 61 72 67 73 2d 74 65 stpatt " args-te
2f40: 73 74 70 61 74 74 20 22 20 72 74 65 73 74 70 61 stpatt " rtestpa
2f50: 74 74 3a 22 20 72 74 65 73 74 70 61 74 74 29 0a tt:" rtestpatt).
2f60: 20 20 20 20 20 20 61 72 67 73 2d 74 65 73 74 70 args-testp
2f70: 61 74 74 29 29 29 29 0a 0a 0a 0a 28 64 65 66 69 att))))....(defi
2f80: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ne (common:get-l
2f90: 69 6e 6b 74 72 65 65 29 0a 20 20 28 6f 72 20 28 inktree). (or (
2fa0: 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 getenv "MT_LINKT
2fb0: 52 45 45 22 29 0a 20 20 20 20 20 20 28 69 66 20 REE"). (if
2fc0: 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 20 20 28 *configdat*.. (
2fd0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
2fe0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
2ff0: 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 0a 09 p" "linktree")..
3000: 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 0a (if *toppath*.
3010: 09 20 20 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f . (conc *to
3020: 70 70 61 74 68 2a 20 22 2f 6c 74 22 29 0a 09 20 ppath* "/lt")..
3030: 20 20 20 20 20 23 66 29 29 29 29 0a 0a 28 64 65 #f))))..(de
3040: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 fine (common:arg
3050: 73 2d 67 65 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 s-get-runname).
3060: 20 28 6c 65 74 20 28 28 72 65 73 20 28 6f 72 20 (let ((res (or
3070: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
3080: 72 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 61 72 runname")... (ar
3090: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e gs:get-arg ":run
30a0: 6e 61 6d 65 22 29 0a 09 09 20 28 67 65 74 65 6e name")... (geten
30b0: 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 29 v "MT_RUNNAME"))
30c0: 29 29 0a 20 20 20 20 3b 3b 20 28 69 66 20 72 65 )). ;; (if re
30d0: 73 20 28 73 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 s (set-environme
30e0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
30f0: 52 55 4e 4e 41 4d 45 22 20 72 65 73 29 29 20 3b RUNNAME" res)) ;
3100: 3b 20 6e 6f 74 20 73 75 72 65 20 69 66 20 74 68 ; not sure if th
3110: 69 73 20 69 73 20 61 20 67 6f 6f 64 20 69 64 65 is is a good ide
3120: 61 2e 20 73 69 64 65 20 65 66 66 65 63 74 20 61 a. side effect a
3130: 6e 64 20 61 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 nd all .... r
3140: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 es))..(define (c
3150: 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 69 65 6c 64 73 ommon:get-fields
3160: 20 63 66 67 64 61 74 29 0a 20 20 28 6c 65 74 20 cfgdat). (let
3170: 28 28 66 69 65 6c 64 73 20 28 68 61 73 68 2d 74 ((fields (hash-t
3180: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3190: 20 63 66 67 64 61 74 20 22 66 69 65 6c 64 73 22 cfgdat "fields"
31a0: 20 27 28 29 29 29 29 0a 20 20 20 20 28 6d 61 70 '()))). (map
31b0: 20 63 61 72 20 66 69 65 6c 64 73 29 29 29 0a 0a car fields)))..
31c0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
31d0: 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 20 args-get-target
31e0: 23 21 6b 65 79 20 28 73 70 6c 69 74 20 23 66 29 #!key (split #f)
31f0: 28 65 78 69 74 2d 69 66 2d 62 61 64 20 23 66 29 (exit-if-bad #f)
3200: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
3210: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
3220: 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 61 74 2a ble? *configdat*
3230: 29 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 69 ) (common:get-fi
3240: 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a elds *configdat*
3250: 29 20 27 28 29 29 29 0a 09 20 28 6e 75 6d 6b 65 ) '())).. (numke
3260: 79 73 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 ys (length keys)
3270: 29 0a 09 20 28 74 61 72 67 65 74 20 20 28 6f 72 ).. (target (or
3280: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
3290: 2d 72 65 71 74 61 72 67 22 29 0a 09 09 20 20 20 -reqtarg")...
32a0: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
32b0: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
32c0: 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (getenv "MT_
32d0: 54 41 52 47 45 54 22 29 29 29 0a 09 20 28 74 6c TARGET"))).. (tl
32e0: 69 73 74 20 20 20 28 69 66 20 74 61 72 67 65 74 ist (if target
32f0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
3300: 61 72 67 65 74 20 22 2f 22 20 23 74 29 20 27 28 arget "/" #t) '(
3310: 29 29 29 0a 09 20 28 76 61 6c 69 64 20 20 20 28 ))).. (valid (
3320: 69 66 20 74 61 72 67 65 74 0a 09 09 20 20 20 20 if target...
3330: 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 6b 65 79 (or (null? key
3340: 73 29 20 3b 3b 20 70 72 6f 62 61 62 6c 79 20 64 s) ;; probably d
3350: 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 72 20 6b 65 on't know our ke
3360: 79 73 20 79 65 74 0a 09 09 09 20 20 28 61 6e 64 ys yet.... (and
3370: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 6c 69 (not (null? tli
3380: 73 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 st)).... (
3390: 65 71 3f 20 6e 75 6d 6b 65 79 73 20 28 6c 65 6e eq? numkeys (len
33a0: 67 74 68 20 74 6c 69 73 74 29 29 0a 09 09 09 20 gth tlist))....
33b0: 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 28 66 69 (null? (fi
33c0: 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e 75 6c 6c lter string-null
33d0: 3f 20 74 6c 69 73 74 29 29 29 29 0a 09 09 20 20 ? tlist))))...
33e0: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 #f))). (i
33f0: 66 20 76 61 6c 69 64 0a 09 28 69 66 20 73 70 6c f valid..(if spl
3400: 69 74 0a 09 20 20 20 20 74 6c 69 73 74 0a 09 20 it.. tlist..
3410: 20 20 20 74 61 72 67 65 74 29 0a 09 28 69 66 20 target)..(if
3420: 74 61 72 67 65 74 0a 09 20 20 20 20 28 62 65 67 target.. (beg
3430: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
3440: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
3450: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3460: 2a 20 22 49 6e 76 61 6c 69 64 20 74 61 72 67 65 * "Invalid targe
3470: 74 2c 20 73 70 61 63 65 73 20 6f 72 20 62 6c 61 t, spaces or bla
3480: 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f 77 65 64 20 nks not allowed
3490: 5c 22 22 20 74 61 72 67 65 74 20 22 5c 22 2c 20 \"" target "\",
34a0: 74 61 72 67 65 74 20 73 68 6f 75 6c 64 20 62 65 target should be
34b0: 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 : " (string-inte
34c0: 72 73 70 65 72 73 65 20 6b 65 79 73 20 22 2f 22 rsperse keys "/"
34d0: 29 20 22 2c 20 68 61 76 65 20 22 20 74 6c 69 73 ) ", have " tlis
34e0: 74 20 22 20 66 6f 72 20 65 6c 65 6d 65 6e 74 73 t " for elements
34f0: 22 29 0a 09 20 20 20 20 20 20 28 69 66 20 65 78 ").. (if ex
3500: 69 74 2d 69 66 2d 62 61 64 20 28 65 78 69 74 20 it-if-bad (exit
3510: 31 29 29 0a 09 20 20 20 20 20 20 23 66 29 0a 09 1)).. #f)..
3520: 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 6c #f))))..;; l
3530: 6f 6f 6b 69 6e 67 20 6f 6e 6c 79 20 28 61 74 20 ooking only (at
3540: 6c 65 61 73 74 20 66 6f 72 20 6e 6f 77 29 20 61 least for now) a
3550: 74 20 74 68 65 20 4d 54 5f 20 76 61 72 69 61 62 t the MT_ variab
3560: 6c 65 73 20 63 72 61 66 74 20 74 68 65 20 66 75 les craft the fu
3570: 6c 6c 20 74 65 73 74 6e 61 6d 65 0a 3b 3b 0a 28 ll testname.;;.(
3580: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
3590: 65 74 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d et-full-test-nam
35a0: 65 29 0a 20 20 28 69 66 20 28 67 65 74 65 6e 76 e). (if (getenv
35b0: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 "MT_TEST_NAME")
35c0: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
35d0: 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d (getenv "MT_ITEM
35e0: 50 41 54 48 22 29 0a 20 20 20 20 20 20 20 20 20 PATH").
35f0: 20 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 (not (equa
3600: 6c 3f 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 l? (getenv "MT_I
3610: 54 45 4d 50 41 54 48 22 29 20 22 22 29 29 29 0a TEMPATH") ""))).
3620: 20 20 20 20 20 20 20 20 20 20 28 67 65 74 65 6e (geten
3630: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
3640: 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e ). (con
3650: 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 c (getenv "MT_TE
3660: 53 54 5f 4e 41 4d 45 22 29 20 22 2f 22 20 28 67 ST_NAME") "/" (g
3670: 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 etenv "MT_ITEMPA
3680: 54 48 22 29 29 29 0a 20 20 20 20 20 20 23 66 29 TH"))). #f)
3690: 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )...;;==========
36a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
36e0: 53 20 54 20 41 20 54 20 45 20 53 20 20 20 41 20 S T A T E S A
36f0: 4e 20 44 20 20 20 53 20 54 20 41 20 54 20 55 20 N D S T A T U
3700: 53 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d S E S.;;========
3710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
3750: 3b 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d ;; BBnote: *comm
3760: 6f 6e 3a 73 74 64 2d 73 74 61 74 65 73 2a 20 2d on:std-states* -
3770: 20 64 61 73 68 62 6f 61 72 64 20 66 69 6c 74 65 dashboard filte
3780: 72 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 65 r control and te
3790: 73 74 20 63 6f 6e 74 72 6f 6c 20 73 74 61 74 65 st control state
37a0: 20 62 75 74 74 6f 6e 73 20 64 65 66 69 6e 65 64 buttons defined
37b0: 20 68 65 72 65 3b 20 75 73 65 64 20 69 6e 20 73 here; used in s
37c0: 65 74 2d 66 69 65 6c 64 73 2d 70 61 6e 65 6c 20 et-fields-panel
37d0: 61 6e 64 20 64 62 6f 61 72 64 3a 6d 61 6b 65 2d and dboard:make-
37e0: 63 6f 6e 74 72 6f 6c 73 0a 28 64 65 66 69 6e 65 controls.(define
37f0: 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 *common:std-sta
3800: 74 65 73 2a 20 20 20 3b 3b 20 66 6f 72 20 74 6f tes* ;; for to
3810: 67 67 6c 65 20 62 75 74 74 6f 6e 73 20 69 6e 20 ggle buttons in
3820: 64 61 73 68 62 6f 61 72 64 0a 20 20 27 28 0a 20 dashboard. '(.
3830: 20 20 20 28 30 20 22 41 52 43 48 49 56 45 44 22 (0 "ARCHIVED"
3840: 29 0a 20 20 20 20 28 31 20 22 53 54 55 43 4b 22 ). (1 "STUCK"
3850: 29 0a 20 20 20 20 28 32 20 22 4b 49 4c 4c 52 45 ). (2 "KILLRE
3860: 51 22 29 0a 20 20 20 20 28 33 20 22 4b 49 4c 4c Q"). (3 "KILL
3870: 45 44 22 29 0a 20 20 20 20 28 34 20 22 4e 4f 54 ED"). (4 "NOT
3880: 5f 53 54 41 52 54 45 44 22 29 0a 20 20 20 20 28 _STARTED"). (
3890: 35 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 20 5 "COMPLETED").
38a0: 20 20 20 28 36 20 22 4c 41 55 4e 43 48 45 44 22 (6 "LAUNCHED"
38b0: 29 0a 20 20 20 20 28 37 20 22 52 45 4d 4f 54 45 ). (7 "REMOTE
38c0: 48 4f 53 54 53 54 41 52 54 22 29 0a 20 20 20 20 HOSTSTART").
38d0: 28 38 20 22 52 55 4e 4e 49 4e 47 22 29 0a 20 20 (8 "RUNNING").
38e0: 20 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 ))..(define *c
38f0: 6f 6d 6d 6f 6e 3a 64 6f 6e 74 2d 72 6f 6c 6c 2d ommon:dont-roll-
3900: 75 70 2d 73 74 61 74 65 73 2a 0a 20 20 27 28 22 up-states*. '("
3910: 44 45 4c 45 54 45 44 22 0a 20 20 20 20 22 52 45 DELETED". "RE
3920: 4d 4f 56 49 4e 47 22 0a 20 20 20 20 22 43 4c 45 MOVING". "CLE
3930: 41 4e 49 4e 47 22 0a 20 20 20 20 22 41 52 43 48 ANING". "ARCH
3940: 49 56 45 5f 52 45 4d 4f 56 49 4e 47 22 0a 20 20 IVE_REMOVING".
3950: 20 20 29 29 0a 0a 3b 3b 20 42 42 6e 6f 74 65 3a ))..;; BBnote:
3960: 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 *common:std-sta
3970: 74 75 73 65 73 2a 20 64 61 73 68 62 6f 61 72 64 tuses* dashboard
3980: 20 66 69 6c 74 65 72 20 63 6f 6e 74 72 6f 6c 20 filter control
3990: 61 6e 64 20 74 65 73 74 20 63 6f 6e 74 72 6f 6c and test control
39a0: 20 73 74 61 74 75 73 20 62 75 74 74 6f 6e 73 20 status buttons
39b0: 64 65 66 69 6e 65 64 20 68 65 72 65 3b 20 75 73 defined here; us
39c0: 65 64 20 69 6e 20 73 65 74 2d 66 69 65 6c 64 73 ed in set-fields
39d0: 2d 70 61 6e 65 6c 20 61 6e 64 20 64 62 6f 61 72 -panel and dboar
39e0: 64 3a 6d 61 6b 65 2d 63 6f 6e 74 72 6f 6c 73 0a d:make-controls.
39f0: 3b 3b 20 6e 6f 74 65 20 74 68 65 73 65 20 73 74 ;; note these st
3a00: 61 74 75 73 65 73 20 61 72 65 20 73 6f 72 74 65 atuses are sorte
3a10: 64 20 66 72 6f 6d 20 62 65 74 74 65 72 20 74 6f d from better to
3a20: 20 77 6f 72 73 65 2e 0a 3b 3b 20 54 68 69 73 20 worse..;; This
3a30: 73 6f 72 74 20 6f 72 64 65 72 20 69 73 20 69 6d sort order is im
3a40: 70 6f 72 74 61 6e 74 20 74 6f 20 64 63 6f 6d 6d portant to dcomm
3a50: 6f 6e 3a 73 74 61 74 75 73 2d 63 6f 6d 70 61 72 on:status-compar
3a60: 65 33 20 61 6e 64 20 64 62 3a 73 65 74 2d 73 74 e3 and db:set-st
3a70: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
3a80: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 0a 28 64 65 oll-up-items.(de
3a90: 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 fine *common:std
3aa0: 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 3b -statuses*. '(;
3ab0: 3b 20 28 30 20 22 44 45 4c 45 54 45 44 22 29 20 ; (0 "DELETED")
3ac0: 20 0a 20 20 20 20 28 31 20 22 6e 2f 61 22 29 0a . (1 "n/a").
3ad0: 20 20 20 20 28 32 20 22 50 41 53 53 22 29 0a 20 (2 "PASS").
3ae0: 20 20 20 28 33 20 22 53 4b 49 50 22 29 0a 20 20 (3 "SKIP").
3af0: 20 20 28 34 20 22 57 41 52 4e 22 29 0a 20 20 20 (4 "WARN").
3b00: 20 28 35 20 22 57 41 49 56 45 44 22 29 0a 20 20 (5 "WAIVED").
3b10: 20 20 28 36 20 22 43 48 45 43 4b 22 29 0a 20 20 (6 "CHECK").
3b20: 20 20 28 37 20 22 53 54 55 43 4b 2f 44 45 41 44 (7 "STUCK/DEAD
3b30: 22 29 0a 20 20 20 20 28 38 20 22 44 45 41 44 22 "). (8 "DEAD"
3b40: 29 0a 20 20 20 20 28 39 20 22 46 41 49 4c 22 29 ). (9 "FAIL")
3b50: 0a 20 20 20 20 28 31 30 20 22 50 52 45 51 5f 46 . (10 "PREQ_F
3b60: 41 49 4c 22 29 0a 20 20 20 20 28 31 31 20 22 50 AIL"). (11 "P
3b70: 52 45 51 5f 44 49 53 43 41 52 44 45 44 22 29 0a REQ_DISCARDED").
3b80: 20 20 20 20 28 31 32 20 22 41 42 4f 52 54 22 29 (12 "ABORT")
3b90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d ))..(define *com
3ba0: 6d 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 73 mon:ended-states
3bb0: 2a 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 * ;; state
3bc0: 73 20 77 68 69 63 68 20 69 6e 64 69 63 61 74 65 s which indicate
3bd0: 20 74 68 65 20 74 65 73 74 20 69 73 20 73 74 6f the test is sto
3be0: 70 70 65 64 20 61 6e 64 20 77 69 6c 6c 20 6e 6f pped and will no
3bf0: 74 20 70 72 6f 63 65 65 64 0a 20 20 27 28 22 43 t proceed. '("C
3c00: 4f 4d 50 4c 45 54 45 44 22 20 22 41 52 43 48 49 OMPLETED" "ARCHI
3c10: 56 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 4b VED" "KILLED" "K
3c20: 49 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 ILLREQ" "STUCK"
3c30: 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 29 29 0a "INCOMPLETE" )).
3c40: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e .(define *common
3c50: 3a 62 61 64 6c 79 2d 65 6e 64 65 64 2d 73 74 61 :badly-ended-sta
3c60: 74 65 73 2a 20 3b 3b 20 74 68 65 73 65 20 72 6f tes* ;; these ro
3c70: 6c 6c 20 75 70 20 61 73 20 43 48 45 43 4b 2c 20 ll up as CHECK,
3c80: 69 2e 65 2e 20 72 65 73 75 6c 74 73 20 6e 65 65 i.e. results nee
3c90: 64 20 74 6f 20 62 65 20 63 68 65 63 6b 65 64 0a d to be checked.
3ca0: 20 20 27 28 22 4b 49 4c 4c 45 44 22 20 22 4b 49 '("KILLED" "KI
3cb0: 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 22 LLREQ" "STUCK" "
3cc0: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 44 45 41 INCOMPLETE" "DEA
3cd0: 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 D"))..(define *c
3ce0: 6f 6d 6d 6f 6e 3a 77 65 6c 6c 2d 65 6e 64 65 64 ommon:well-ended
3cf0: 2d 73 74 61 74 65 73 2a 20 3b 3b 20 61 6e 20 69 -states* ;; an i
3d00: 74 65 6d 27 73 20 70 72 65 72 65 71 20 69 6e 20 tem's prereq in
3d10: 74 68 69 73 20 73 74 61 74 65 20 61 6c 6c 6f 77 this state allow
3d20: 73 20 69 74 65 6d 20 74 6f 20 70 72 6f 63 65 65 s item to procee
3d30: 64 0a 20 20 27 28 22 50 41 53 53 22 20 22 57 41 d. '("PASS" "WA
3d40: 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 RN" "CHECK" "WAI
3d50: 56 45 44 22 20 22 53 4b 49 50 22 29 29 0a 0a 3b VED" "SKIP"))..;
3d60: 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d 6f ; BBnote: *commo
3d70: 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 n:running-states
3d80: 2a 20 75 73 65 64 20 66 72 6f 6d 20 64 62 3a 73 * used from db:s
3d90: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
3da0: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
3db0: 73 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f s.(define *commo
3dc0: 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 n:running-states
3dd0: 2a 20 20 20 20 20 3b 3b 20 74 65 73 74 20 69 73 * ;; test is
3de0: 20 65 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 either running
3df0: 6f 72 20 63 61 6e 20 62 65 20 72 75 6e 0a 20 20 or can be run.
3e00: 27 28 22 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d '("RUNNING" "REM
3e10: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 4c OTEHOSTSTART" "L
3e20: 41 55 4e 43 48 45 44 22 20 22 53 54 41 52 54 45 AUNCHED" "STARTE
3e30: 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 D"))..(define *c
3e40: 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 ommon:cant-run-s
3e50: 74 61 74 65 73 2a 20 20 20 20 3b 3b 20 54 68 65 tates* ;; The
3e60: 73 65 20 61 72 65 20 73 74 6f 70 70 69 6e 67 20 se are stopping
3e70: 63 6f 6e 64 69 74 69 6f 6e 73 20 74 68 61 74 20 conditions that
3e80: 70 72 65 76 65 6e 74 20 61 20 74 65 73 74 20 66 prevent a test f
3e90: 72 6f 6d 20 62 65 69 6e 67 20 72 75 6e 0a 20 20 rom being run.
3ea0: 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 4b '("COMPLETED" "K
3eb0: 49 4c 4c 45 44 22 20 22 55 4e 4b 4e 4f 57 4e 22 ILLED" "UNKNOWN"
3ec0: 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 41 "INCOMPLETE" "A
3ed0: 52 43 48 49 56 45 44 22 29 29 0a 0a 28 64 65 66 RCHIVED"))..(def
3ee0: 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 6e 6f 74 2d ine *common:not-
3ef0: 73 74 61 72 74 65 64 2d 6f 6b 2d 73 74 61 74 75 started-ok-statu
3f00: 73 65 73 2a 20 3b 3b 20 69 66 20 6e 6f 74 20 6f ses* ;; if not o
3f10: 6e 65 20 6f 66 20 74 68 65 73 65 20 73 74 61 74 ne of these stat
3f20: 75 73 65 73 20 77 68 65 6e 20 69 6e 20 6e 6f 74 uses when in not
3f30: 5f 73 74 61 72 74 65 64 20 73 74 61 74 65 20 74 _started state t
3f40: 72 65 61 74 20 61 73 20 64 65 61 64 0a 20 20 27 reat as dead. '
3f50: 28 22 6e 2f 61 22 20 22 6e 61 22 20 22 50 41 53 ("n/a" "na" "PAS
3f60: 53 22 20 22 46 41 49 4c 22 20 22 57 41 52 4e 22 S" "FAIL" "WARN"
3f70: 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 "CHECK" "WAIVED
3f80: 22 20 22 44 45 41 44 22 20 22 53 4b 49 50 22 29 " "DEAD" "SKIP")
3f90: 29 0a 0a 3b 3b 20 67 72 6f 75 70 20 74 65 73 74 )..;; group test
3fa0: 73 20 69 6e 74 6f 20 62 75 63 6b 65 74 73 20 63 s into buckets c
3fb0: 6f 72 72 65 73 70 6f 6e 64 69 6e 67 20 74 6f 20 orresponding to
3fc0: 72 6f 6c 6c 75 70 0a 3b 3b 3b 20 52 75 6e 6e 69 rollup.;;; Runni
3fd0: 6e 67 2c 20 63 6f 6d 70 6c 65 74 65 64 2d 70 61 ng, completed-pa
3fe0: 73 73 2c 20 20 63 6f 6d 70 6c 65 74 65 64 2d 6e ss, completed-n
3ff0: 6f 6e 2d 70 61 73 73 20 2b 20 77 6f 72 73 74 20 on-pass + worst
4000: 73 74 61 74 75 73 2c 20 6e 6f 74 20 73 74 61 72 status, not star
4010: 74 65 64 2e 0a 3b 3b 20 66 69 6c 74 65 72 20 6f ted..;; filter o
4020: 75 74 20 0a 3b 28 64 65 66 69 6e 65 20 28 63 6f ut .;(define (co
4030: 6d 6d 6f 6e 3a 63 61 74 65 67 6f 72 69 7a 65 2d mmon:categorize-
4040: 69 74 65 6d 73 2d 66 6f 72 2d 72 6f 6c 6c 75 70 items-for-rollup
4050: 20 69 6e 2d 74 65 73 74 73 29 0a 3b 20 20 28 0a in-tests).; (.
4060: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
4070: 3a 73 70 65 63 69 61 6c 2d 73 6f 72 74 20 69 74 :special-sort it
4080: 65 6d 73 20 6f 72 64 65 72 20 63 6f 6d 70 29 0a ems order comp).
4090: 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6f (let ((items-o
40a0: 72 64 65 72 20 28 6d 61 70 20 72 65 76 65 72 73 rder (map revers
40b0: 65 20 6f 72 64 65 72 29 29 0a 20 20 20 20 20 20 e order)).
40c0: 20 20 28 61 63 6f 6d 70 20 20 20 20 20 20 20 28 (acomp (
40d0: 6f 72 20 63 6f 6d 70 20 3e 29 29 29 0a 20 20 20 or comp >))).
40e0: 20 28 73 6f 72 74 20 69 74 65 6d 73 0a 20 20 20 (sort items.
40f0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 (lambda (a
4100: 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 b). (le
4110: 74 20 28 28 61 2d 6e 75 6d 20 28 63 61 64 72 20 t ((a-num (cadr
4120: 28 6f 72 20 28 61 73 73 6f 63 20 61 20 69 74 65 (or (assoc a ite
4130: 6d 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 ms-order) '(0 0)
4140: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
4150: 20 20 20 20 28 62 2d 6e 75 6d 20 28 63 61 64 72 (b-num (cadr
4160: 20 28 6f 72 20 28 61 73 73 6f 63 20 62 20 69 74 (or (assoc b it
4170: 65 6d 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 ems-order) '(0 0
4180: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
4190: 20 20 28 61 63 6f 6d 70 20 61 2d 6e 75 6d 20 62 (acomp a-num b
41a0: 2d 6e 75 6d 29 29 29 29 29 29 0a 0a 3b 3b 20 3b -num))))))..;; ;
41b0: 3b 20 67 69 76 65 6e 20 61 20 74 6f 70 6c 65 76 ; given a toplev
41c0: 65 6c 20 77 69 74 68 20 63 75 72 72 73 74 61 74 el with currstat
41d0: 65 2c 20 63 75 72 72 73 74 61 74 75 73 20 61 70 e, currstatus ap
41e0: 70 6c 79 20 73 74 61 74 65 20 61 6e 64 20 73 74 ply state and st
41f0: 61 74 75 73 0a 3b 3b 20 3b 3b 20 20 3d 3e 20 28 atus.;; ;; => (
4200: 6e 65 77 73 74 61 74 65 20 2e 20 6e 65 77 73 74 newstate . newst
4210: 61 74 75 73 29 0a 3b 3b 20 28 64 65 66 69 6e 65 atus).;; (define
4220: 20 28 63 6f 6d 6d 6f 6e 3a 61 70 70 6c 79 2d 73 (common:apply-s
4230: 74 61 74 65 2d 73 74 61 74 75 73 20 63 75 72 72 tate-status curr
4240: 73 74 61 74 65 20 63 75 72 72 73 74 61 74 75 73 state currstatus
4250: 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b state status).;
4260: 3b 20 20 20 28 6c 65 74 2a 20 28 28 63 73 74 61 ; (let* ((csta
4270: 74 65 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d te (string->sym
4280: 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e bol (string-down
4290: 63 61 73 65 20 63 75 72 72 73 74 61 74 65 29 29 case currstate))
42a0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 63 ).;; (c
42b0: 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e status (string->
42c0: 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 symbol (string-d
42d0: 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 61 74 owncase currstat
42e0: 75 73 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 us))).;;
42f0: 20 20 28 73 73 74 61 74 65 20 20 28 73 74 72 69 (sstate (stri
4300: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 ng->symbol (stri
4310: 6e 67 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 ng-downcase stat
4320: 65 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 e))).;;
4330: 20 28 73 73 74 61 74 75 73 20 28 73 74 72 69 6e (sstatus (strin
4340: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
4350: 67 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 75 g-downcase statu
4360: 73 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 s))).;;
4370: 20 28 6e 73 74 61 74 65 20 20 23 66 29 0a 3b 3b (nstate #f).;;
4380: 20 20 20 20 20 20 20 20 20 20 28 6e 73 74 61 74 (nstat
4390: 75 73 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 28 us #f)).;; (
43a0: 73 65 74 21 20 6e 73 74 61 74 65 0a 3b 3b 20 20 set! nstate.;;
43b0: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 63 (case c
43c0: 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 state.;;
43d0: 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 ((completed
43e0: 20 6e 6f 74 5f 73 74 61 72 74 65 64 20 6b 69 6c not_started kil
43f0: 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 led killreq stuc
4400: 6b 20 61 72 63 68 69 76 65 64 29 20 0a 3b 3b 20 k archived) .;;
4410: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
4420: 73 65 20 73 73 74 61 74 65 20 3b 3b 20 63 6f 6d se sstate ;; com
4430: 70 6c 65 74 65 64 20 2d 3e 20 73 73 74 61 74 65 pleted -> sstate
4440: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4450: 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b ((completed k
4460: 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 illed killreq st
4470: 75 63 6b 20 61 72 63 68 69 76 65 64 29 20 63 6f uck archived) co
4480: 6d 70 6c 65 74 65 64 29 0a 3b 3b 20 20 20 20 20 mpleted).;;
4490: 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 6e ((run
44a0: 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 ning remotehosts
44b0: 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 tart launched)
44c0: 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b running).;
44d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
44e0: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
44f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4500: 20 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e unkn
4510: 6f 77 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a 3b own-error-1))).;
4520: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ; ((
4530: 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f running remoteho
4540: 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 ststart launched
4550: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
4560: 20 20 28 63 61 73 65 20 73 73 74 61 74 65 0a 3b (case sstate.;
4570: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4580: 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c ((completed kil
4590: 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 led killreq stuc
45a0: 6b 20 61 72 63 68 69 76 65 64 29 20 23 66 29 20 k archived) #f)
45b0: 3b 3b 20 6e 65 65 64 20 74 6f 20 6c 6f 6f 6b 20 ;; need to look
45c0: 61 74 20 61 6c 6c 20 69 74 65 6d 73 0a 3b 3b 20 at all items.;;
45d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
45e0: 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 (running remoteh
45f0: 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 oststart launche
4600: 64 29 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e d) runnin
4610: 67 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 g).;;
4620: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4650: 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 32 29 unknown-error-2)
4660: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 )).;;
4670: 20 20 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d (else unknown-
4680: 65 72 72 6f 72 2d 33 29 29 29 0a 3b 3b 20 20 20 error-3))).;;
4690: 20 20 28 73 65 74 21 20 6e 73 74 61 74 75 73 0a (set! nstatus.
46a0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 63 61 ;; (ca
46b0: 73 65 20 73 73 74 61 74 75 73 0a 3b 3b 20 20 20 se sstatus.;;
46c0: 20 20 20 20 20 20 20 20 20 20 28 28 70 61 73 73 ((pass
46d0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
46e0: 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 0a 3b (case nstate.;
46f0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4700: 20 28 28 70 61 73 73 20 6e 2f 61 20 64 65 6c 65 ((pass n/a dele
4710: 74 65 64 29 20 20 20 20 20 70 61 73 73 29 0a 3b ted) pass).;
4720: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4730: 20 28 28 77 61 72 6e 29 20 20 20 20 20 20 20 20 ((warn)
4740: 20 20 20 20 20 20 20 20 20 77 61 72 6e 29 0a 3b warn).;
4750: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4760: 20 28 28 66 61 69 6c 29 20 20 20 20 20 20 20 20 ((fail)
4770: 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 0a 3b fail).;
4780: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4790: 20 28 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 ((check)
47a0: 20 20 20 20 20 20 20 20 63 68 65 63 6b 29 0a 3b check).;
47b0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
47c0: 20 28 28 77 61 69 76 65 64 29 20 20 20 20 20 20 ((waived)
47d0: 20 20 20 20 20 20 20 77 61 69 76 65 64 29 0a 3b waived).;
47e0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
47f0: 20 28 28 73 6b 69 70 29 20 20 20 20 20 20 20 20 ((skip)
4800: 20 20 20 20 20 20 20 20 20 73 6b 69 70 29 0a 3b skip).;
4810: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4820: 20 28 28 73 74 75 63 6b 2f 64 65 61 64 29 20 20 ((stuck/dead)
4830: 20 20 20 20 20 20 20 20 73 74 75 63 6b 29 0a 3b stuck).;
4840: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4850: 20 28 28 61 62 6f 72 74 29 20 20 20 20 20 20 20 ((abort)
4860: 20 20 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b abort).;
4870: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4880: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 75 6e (else un
4890: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 34 29 29 29 known-error-4)))
48a0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
48b0: 28 28 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 ((warn).;;
48c0: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 (case ns
48d0: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
48e0: 20 20 20 20 20 20 20 28 28 70 61 73 73 20 77 61 ((pass wa
48f0: 72 6e 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c 65 rn n/a skip dele
4900: 74 65 64 29 20 20 20 77 61 72 6e 29 0a 3b 3b 20 ted) warn).;;
4910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4920: 28 66 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 (fail)
4930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 f
4940: 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ail).;;
4950: 20 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 ((check)
4960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4970: 20 20 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 check).;;
4980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4990: 28 77 61 69 76 65 64 29 20 20 20 20 20 20 20 20 (waived)
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 wai
49b0: 76 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ved).;;
49c0: 20 20 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 ((stuck/d
49d0: 65 61 64 29 20 20 20 20 20 20 20 20 20 20 20 20 ead)
49e0: 20 20 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 stuck).;;
49f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4a00: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
4a10: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
4a20: 72 2d 35 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 r-5))).;;
4a30: 20 20 20 20 20 20 28 28 66 61 69 6c 29 0a 3b 3b ((fail).;;
4a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
4a50: 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 ase nstate.;;
4a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 ((p
4a70: 61 73 73 20 77 61 72 6e 20 66 61 69 6c 20 63 68 ass warn fail ch
4a80: 65 63 6b 20 6e 2f 61 20 77 61 69 76 65 64 20 73 eck n/a waived s
4a90: 6b 69 70 20 64 65 6c 65 74 65 64 20 73 74 75 63 kip deleted stuc
4aa0: 6b 2f 64 65 61 64 20 73 74 75 63 6b 29 20 20 66 k/dead stuck) f
4ab0: 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ail).;;
4ac0: 20 20 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 ((abort)
4ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b00: 20 20 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b abort).;
4b10: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4b20: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
4b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b50: 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d unknown-
4b60: 65 72 72 6f 72 2d 36 29 29 29 0a 3b 3b 20 20 20 error-6))).;;
4b70: 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 (else
4b80: 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 unknown-error
4b90: 2d 37 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 6f -7))).;; (co
4ba0: 6e 73 20 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 ns .;; (if
4bb0: 6e 73 74 61 74 65 20 20 28 73 79 6d 62 6f 6c 2d nstate (symbol-
4bc0: 3e 73 74 72 69 6e 67 20 6e 73 74 61 74 65 29 20 >string nstate)
4bd0: 20 6e 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 20 nstate).;;
4be0: 20 28 69 66 20 6e 73 74 61 74 75 73 20 28 73 79 (if nstatus (sy
4bf0: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 74 mbol->string nst
4c00: 61 74 75 73 29 20 6e 73 74 61 74 75 73 29 29 29 atus) nstatus)))
4c10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4c20: 20 0a 0a 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ....;; (define
4c30: 2a 77 64 6e 75 6d 2a 20 30 29 0a 3b 3b 20 28 64 *wdnum* 0).;; (d
4c40: 65 66 69 6e 65 20 2a 77 64 6e 75 6d 2a 6d 75 74 efine *wdnum*mut
4c50: 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 ex (make-mutex))
4c60: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ...(define (comm
4c70: 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 0a 20 on:human-time).
4c80: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 (time->string (
4c90: 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
4ca0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
4cb0: 6f 6e 64 73 29 29 20 22 25 59 2d 25 6d 2d 25 64 onds)) "%Y-%m-%d
4cc0: 20 25 48 3a 25 4d 3a 25 53 22 29 29 0a 0a 0a 28 %H:%M:%S"))...(
4cd0: 64 65 66 69 6e 65 20 2a 74 69 6d 65 2d 7a 65 72 define *time-zer
4ce0: 6f 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f o* (current-seco
4cf0: 6e 64 73 29 29 20 3b 3b 20 66 6f 72 20 74 68 65 nds)) ;; for the
4d00: 20 77 61 74 63 68 64 6f 67 0a 0a 0a 3b 3b 3d 3d watchdog...;;==
4d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d50: 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 ====.;; M I S C
4d60: 20 20 55 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d U T I L S.;;==
4d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4db0: 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 ====..;; convert
4dc0: 20 73 74 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 stuff to a numb
4dd0: 65 72 20 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 er if possible.(
4de0: 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d define (any->num
4df0: 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 ber val). (cond
4e00: 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 . ((number? v
4e10: 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 73 74 al) val). ((st
4e20: 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 69 ring? val) (stri
4e30: 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 ng->number val))
4e40: 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 . ((symbol? va
4e50: 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 l) (any->number
4e60: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
4e70: 76 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 val))). (else
4e80: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
4e90: 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 any->number-if-p
4ea0: 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 ossible val). (
4eb0: 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e let ((num (any->
4ec0: 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 20 number val))).
4ed0: 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 (if num num va
4ee0: 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 l)))..(define (p
4ef0: 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 att-list-match i
4f00: 74 65 6d 20 70 61 74 74 73 29 0a 20 20 28 64 65 tem patts). (de
4f10: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
4f20: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4f30: 72 74 2a 20 22 70 61 74 74 2d 6c 69 73 74 2d 6d rt* "patt-list-m
4f40: 61 74 63 68 20 69 74 65 6d 3d 22 20 69 74 65 6d atch item=" item
4f50: 20 22 20 70 61 74 74 73 3d 22 20 70 61 74 74 73 " patts=" patts
4f60: 29 0a 20 20 28 69 66 20 28 61 6e 64 20 69 74 65 ). (if (and ite
4f70: 6d 20 70 61 74 74 73 29 20 20 3b 3b 20 68 65 72 m patts) ;; her
4f80: 65 20 77 65 20 61 72 65 20 66 69 6c 74 65 72 69 e we are filteri
4f90: 6e 67 20 66 6f 72 20 6d 61 74 63 68 65 73 20 77 ng for matches w
4fa0: 69 74 68 20 69 74 65 6d 20 70 61 74 74 65 72 6e ith item pattern
4fb0: 73 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 s. (let ((r
4fc0: 65 73 20 23 66 29 29 20 20 20 3b 3b 20 6c 6f 6f es #f)) ;; loo
4fd0: 6b 20 74 68 72 6f 75 67 68 20 61 6c 6c 20 74 68 k through all th
4fe0: 65 20 69 74 65 6d 2d 70 61 74 74 73 20 69 66 20 e item-patts if
4ff0: 64 65 66 69 6e 65 64 2c 20 66 6f 72 6d 61 74 20 defined, format
5000: 69 73 20 70 61 74 74 31 2c 70 61 74 74 32 2c 70 is patt1,patt2,p
5010: 61 74 74 33 20 2e 2e 2e 20 77 69 6c 64 63 61 72 att3 ... wildcar
5020: 64 20 69 73 20 25 0a 09 28 66 6f 72 2d 65 61 63 d is %..(for-eac
5030: 68 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 70 61 h .. (lambda (pa
5040: 74 74 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6d tt).. (let ((m
5050: 6f 64 70 61 74 74 20 28 73 74 72 69 6e 67 2d 73 odpatt (string-s
5060: 75 62 73 74 69 74 75 74 65 20 22 25 22 20 22 2e ubstitute "%" ".
5070: 2a 22 20 70 61 74 74 20 23 74 29 29 29 0a 09 20 *" patt #t)))..
5080: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5090: 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 61 75 6c -info 10 *defaul
50a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 t-log-port* "pat
50b0: 74 20 22 20 70 61 74 74 20 22 20 6d 6f 64 70 61 t " patt " modpa
50c0: 74 74 20 22 20 6d 6f 64 70 61 74 74 29 0a 09 20 tt " modpatt)..
50d0: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d (if (string-
50e0: 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 6d 6f match (regexp mo
50f0: 64 70 61 74 74 29 20 69 74 65 6d 29 0a 09 09 20 dpatt) item)...
5100: 28 73 65 74 21 20 72 65 73 20 23 74 29 29 29 29 (set! res #t))))
5110: 0a 09 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 .. (string-split
5120: 20 70 61 74 74 73 20 22 2c 22 29 29 0a 09 72 65 patts ","))..re
5130: 73 29 0a 20 20 20 20 20 20 23 74 29 29 0a 0a 3b s). #t))..;
5140: 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 63 ; return first c
5150: 6f 6d 6d 61 6e 64 20 74 68 61 74 20 65 78 69 73 ommand that exis
5160: 74 73 2c 20 65 6c 73 65 20 23 66 0a 3b 3b 0a 28 ts, else #f.;;.(
5170: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
5180: 68 69 63 68 20 63 6d 64 73 29 0a 20 20 28 69 66 hich cmds). (if
5190: 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 20 20 (null? cmds).
51a0: 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 6c 65 #f. (le
51b0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
51c0: 72 20 63 6d 64 73 29 29 0a 09 09 20 28 74 61 6c r cmds))... (tal
51d0: 20 28 63 64 72 20 63 6d 64 73 29 29 29 0a 09 28 (cdr cmds)))..(
51e0: 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 2d let ((res (with-
51f0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
5200: 28 63 6f 6e 63 20 22 77 68 69 63 68 20 22 20 68 (conc "which " h
5210: 65 64 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 29 ed) read-line)))
5220: 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 .. (if (and (st
5230: 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 ring? res)...
5240: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
5250: 73 74 73 3f 20 72 65 73 29 29 0a 09 20 20 20 20 sts? res))..
5260: 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 69 66 res.. (if
5270: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
5280: 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 #f... (loop (c
5290: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
52a0: 29 29 29 29 29 29 29 0a 20 20 0a 28 64 65 66 69 ))))))). .(defi
52b0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 ne (common:get-i
52c0: 6e 73 74 61 6c 6c 2d 61 72 65 61 29 0a 20 20 28 nstall-area). (
52d0: 6c 65 74 20 28 28 65 78 65 2d 70 61 74 68 20 28 let ((exe-path (
52e0: 63 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 car (argv)))).
52f0: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (if (common:fi
5300: 6c 65 2d 65 78 69 73 74 73 3f 20 65 78 65 2d 70 le-exists? exe-p
5310: 61 74 68 29 0a 09 28 68 61 6e 64 6c 65 2d 65 78 ath)..(handle-ex
5320: 63 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e 0a 09 ceptions.. exn..
5330: 20 23 66 0a 09 20 28 70 61 74 68 6e 61 6d 65 2d #f.. (pathname-
5340: 64 69 72 65 63 74 6f 72 79 0a 09 20 20 28 70 61 directory.. (pa
5350: 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 thname-directory
5360: 20 0a 09 20 20 20 28 70 61 74 68 6e 61 6d 65 2d .. (pathname-
5370: 64 69 72 65 63 74 6f 72 79 20 65 78 65 2d 70 61 directory exe-pa
5380: 74 68 29 29 29 29 0a 09 23 66 29 29 29 0a 0a 3b th))))..#f)))..;
5390: 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 70 ; return first p
53a0: 61 74 68 20 74 68 61 74 20 63 61 6e 20 62 65 20 ath that can be
53b0: 63 72 65 61 74 65 64 20 6f 72 20 61 6c 72 65 61 created or alrea
53c0: 64 79 20 65 78 69 73 74 73 20 61 6e 64 20 69 73 dy exists and is
53d0: 20 77 72 69 74 61 62 6c 65 0a 3b 3b 0a 28 64 65 writable.;;.(de
53e0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
53f0: 2d 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 6c -create-writeabl
5400: 65 2d 64 69 72 20 64 69 72 73 29 0a 20 20 28 69 e-dir dirs). (i
5410: 66 20 28 6e 75 6c 6c 3f 20 64 69 72 73 29 0a 20 f (null? dirs).
5420: 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 6c #f. (l
5430: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
5440: 61 72 20 64 69 72 73 29 29 0a 09 09 20 28 74 61 ar dirs))... (ta
5450: 6c 20 28 63 64 72 20 64 69 72 73 29 29 29 0a 09 l (cdr dirs)))..
5460: 28 6c 65 74 20 28 28 72 65 73 20 28 6f 72 20 28 (let ((res (or (
5470: 61 6e 64 20 28 64 69 72 65 63 74 6f 72 79 3f 20 and (directory?
5480: 68 65 64 29 0a 09 09 09 20 20 20 20 28 66 69 6c hed).... (fil
5490: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
54a0: 68 65 64 29 0a 09 09 09 20 20 20 20 68 65 64 29 hed).... hed)
54b0: 0a 09 09 20 20 20 20 20 20 20 28 68 61 6e 64 6c ... (handl
54c0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
54d0: 20 20 20 65 78 6e 0a 09 09 09 20 20 20 28 62 65 exn.... (be
54e0: 67 69 6e 0a 09 09 09 20 20 20 20 20 28 64 65 62 gin.... (deb
54f0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5500: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5510: 74 2a 20 22 63 6f 75 6c 64 20 6e 6f 74 20 63 72 t* "could not cr
5520: 65 61 74 65 20 22 20 68 65 64 20 22 2c 20 74 68 eate " hed ", th
5530: 69 73 20 6d 69 67 68 74 20 63 61 75 73 65 20 70 is might cause p
5540: 72 6f 62 6c 65 6d 73 20 64 6f 77 6e 20 74 68 65 roblems down the
5550: 20 72 6f 61 64 2e 22 29 0a 09 09 09 20 20 20 20 road.")....
5560: 20 23 66 29 0a 09 09 09 28 63 72 65 61 74 65 2d #f)....(create-
5570: 64 69 72 65 63 74 6f 72 79 20 68 65 64 20 23 74 directory hed #t
5580: 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e ))))).. (if (an
5590: 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a d (string? res).
55a0: 09 09 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f .. (directory?
55b0: 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 res)).. re
55c0: 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 s.. (if (nu
55d0: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a ll? tal)... #f.
55e0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
55f0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
5600: 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 74 )))..;; return t
5610: 68 65 20 79 6f 75 6e 67 65 73 74 20 74 69 6d 65 he youngest time
5620: 73 74 61 6d 70 20 2e 20 66 69 6c 65 6e 61 6d 65 stamp . filename
5630: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
5640: 6d 6f 6e 3a 67 65 74 2d 79 6f 75 6e 67 65 73 74 mon:get-youngest
5650: 20 67 6c 6f 62 2d 6c 69 73 74 29 0a 20 20 28 6c glob-list). (l
5660: 65 74 20 28 28 61 6c 6c 2d 66 69 6c 65 73 20 28 et ((all-files (
5670: 61 70 70 6c 79 20 61 70 70 65 6e 64 0a 09 09 09 apply append....
5680: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
5690: 70 61 74 74 29 0a 09 09 09 09 20 28 68 61 6e 64 patt)..... (hand
56a0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
56b0: 09 09 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 .. exn.....
56c0: 20 20 20 20 27 28 29 0a 09 09 09 09 20 20 20 28 '()..... (
56d0: 67 6c 6f 62 20 70 61 74 74 29 29 29 0a 09 09 09 glob patt)))....
56e0: 20 20 20 20 20 20 20 67 6c 6f 62 2d 6c 69 73 74 glob-list
56f0: 29 29 29 29 0a 20 20 20 20 28 66 6f 6c 64 20 28 )))). (fold (
5700: 6c 61 6d 62 64 61 20 28 66 6e 61 6d 65 20 72 65 lambda (fname re
5710: 73 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6c s).. (let ((l
5720: 61 73 74 2d 6d 6f 64 20 28 63 61 72 20 72 65 73 ast-mod (car res
5730: 29 29 0a 09 09 20 20 28 63 75 72 6d 6f 64 20 20 ))... (curmod
5740: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
5750: 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 09 ons.....exn.....
5760: 30 0a 09 09 09 20 20 20 20 20 20 28 66 69 6c 65 0.... (file
5770: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
5780: 6d 65 20 66 6e 61 6d 65 29 29 29 29 0a 09 20 20 me fname))))..
5790: 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 6d 6f (if (> curmo
57a0: 64 20 6c 61 73 74 2d 6d 6f 64 29 0a 09 09 20 20 d last-mod)...
57b0: 28 6c 69 73 74 20 63 75 72 6d 6f 64 20 66 6e 61 (list curmod fna
57c0: 6d 65 29 0a 09 09 20 20 72 65 73 29 29 29 0a 09 me)... res)))..
57d0: 20 20 27 28 30 20 22 6e 2f 61 22 29 0a 09 20 20 '(0 "n/a")..
57e0: 61 6c 6c 2d 66 69 6c 65 73 29 29 29 0a 0a 3b 3b all-files)))..;;
57f0: 20 75 73 65 20 62 61 73 68 20 74 6f 20 65 78 70 use bash to exp
5800: 61 6e 64 20 61 20 67 6c 6f 62 2e 20 44 6f 65 73 and a glob. Does
5810: 20 4e 4f 54 20 68 61 6e 64 6c 65 20 70 61 74 68 NOT handle path
5820: 73 20 77 69 74 68 20 73 70 61 63 65 73 21 0a 3b s with spaces!.;
5830: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
5840: 6e 3a 62 61 73 68 2d 67 6c 6f 62 20 69 6e 73 74 n:bash-glob inst
5850: 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 73 70 6c r). (string-spl
5860: 69 74 0a 20 20 20 28 77 69 74 68 2d 69 6e 70 75 it. (with-inpu
5870: 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 t-from-pipe.
5880: 20 20 20 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 62 (conc "/bin/b
5890: 61 73 68 20 2d 63 20 5c 22 65 63 68 6f 20 22 20 ash -c \"echo "
58a0: 69 6e 73 74 72 20 22 5c 22 22 29 0a 20 20 20 20 instr "\"").
58b0: 20 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 20 20 read-line))).
58c0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
58d0: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 61 :file-exists? pa
58e0: 74 68 2d 73 74 72 69 6e 67 20 23 21 6b 65 79 20 th-string #!key
58f0: 28 73 69 6c 65 6e 74 20 23 66 29 29 0a 20 20 3b (silent #f)). ;
5900: 3b 20 74 68 69 73 20 61 76 6f 69 64 73 20 73 74 ; this avoids st
5910: 61 63 6b 20 64 75 6d 70 73 20 69 6e 20 74 68 65 ack dumps in the
5920: 20 63 61 73 65 20 77 68 65 72 65 20 0a 0a 20 20 case where ..
5930: 3b 3b 3b 3b 20 54 4f 44 4f 3a 20 63 61 74 63 68 ;;;; TODO: catch
5940: 20 70 65 72 6d 69 73 73 69 6f 6e 20 64 65 6e 69 permission deni
5950: 65 64 20 65 78 63 65 70 74 69 6f 6e 73 20 61 6e ed exceptions an
5960: 64 20 65 6d 69 74 20 61 70 70 72 6f 70 72 69 61 d emit appropria
5970: 74 65 20 77 61 72 6e 69 6e 67 73 2c 20 65 67 3a te warnings, eg:
5980: 20 20 73 79 73 74 65 6d 20 65 72 72 6f 72 20 77 system error w
5990: 68 69 6c 65 20 74 72 79 69 6e 67 20 74 6f 20 61 hile trying to a
59a0: 63 63 65 73 73 20 66 69 6c 65 3a 20 22 2f 6e 66 ccess file: "/nf
59b0: 73 2f 70 64 78 2f 64 69 73 6b 73 2f 69 63 66 5f s/pdx/disks/icf_
59c0: 65 6e 76 5f 64 69 73 6b 30 30 31 2f 62 6a 62 61 env_disk001/bjba
59d0: 72 63 6c 61 2f 67 77 61 2f 69 73 73 75 65 73 2f rcla/gwa/issues/
59e0: 6d 74 64 65 76 2f 72 61 6e 64 79 2d 73 6c 6f 77 mtdev/randy-slow
59f0: 2f 72 65 70 72 6f 64 75 63 65 2f 71 2e 2e 2e 0a /reproduce/q....
5a00: 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 6c 73 65 2d (common:false-
5a10: 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 20 28 6c 61 on-exception (la
5a20: 6d 62 64 61 20 28 29 20 28 66 69 6c 65 2d 65 78 mbda () (file-ex
5a30: 69 73 74 73 3f 20 70 61 74 68 2d 73 74 72 69 6e ists? path-strin
5a40: 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 g)).
5a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a60: 20 6d 65 73 73 61 67 65 3a 20 28 69 66 20 28 6e message: (if (n
5a70: 6f 74 20 73 69 6c 65 6e 74 29 0a 20 20 20 20 20 ot silent).
5a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5aa0: 20 20 20 20 20 28 63 6f 6e 63 20 22 55 6e 61 62 (conc "Unab
5ab0: 6c 65 20 74 6f 20 61 63 63 65 73 73 20 70 61 74 le to access pat
5ac0: 68 3a 20 22 20 70 61 74 68 2d 73 74 72 69 6e 67 h: " path-string
5ad0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5af0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
5b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 0a )).
5b20: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ...(define (comm
5b30: 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 63 65 on:false-on-exce
5b40: 70 74 69 6f 6e 20 74 68 75 6e 6b 20 23 21 6b 65 ption thunk #!ke
5b50: 79 20 28 6d 65 73 73 61 67 65 20 23 66 29 29 0a y (message #f)).
5b60: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
5b70: 69 6f 6e 73 20 65 78 6e 0a 20 20 20 20 20 20 20 ions exn.
5b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
5b90: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
5ba0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5bb0: 6d 65 73 73 61 67 65 0a 20 20 20 20 20 20 20 20 message.
5bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bd0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5be0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5bf0: 6c 6f 67 2d 70 6f 72 74 2a 20 6d 65 73 73 61 67 log-port* messag
5c00: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
5c10: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 28 #f) (
5c20: 74 68 75 6e 6b 29 20 29 29 0a 0a 28 64 65 66 69 thunk) ))..(defi
5c30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 65 63 ne (common:direc
5c40: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 74 tory-exists? pat
5c50: 68 2d 73 74 72 69 6e 67 29 0a 20 20 3b 3b 3b 3b h-string). ;;;;
5c60: 20 54 4f 44 4f 3a 20 63 61 74 63 68 20 70 65 72 TODO: catch per
5c70: 6d 69 73 73 69 6f 6e 20 64 65 6e 69 65 64 20 65 mission denied e
5c80: 78 63 65 70 74 69 6f 6e 73 20 61 6e 64 20 65 6d xceptions and em
5c90: 69 74 20 61 70 70 72 6f 70 72 69 61 74 65 20 77 it appropriate w
5ca0: 61 72 6e 69 6e 67 73 2c 20 65 67 3a 20 20 73 79 arnings, eg: sy
5cb0: 73 74 65 6d 20 65 72 72 6f 72 20 77 68 69 6c 65 stem error while
5cc0: 20 74 72 79 69 6e 67 20 74 6f 20 61 63 63 65 73 trying to acces
5cd0: 73 20 66 69 6c 65 3a 20 22 2f 6e 66 73 2f 70 64 s file: "/nfs/pd
5ce0: 78 2f 64 69 73 6b 73 2f 69 63 66 5f 65 6e 76 5f x/disks/icf_env_
5cf0: 64 69 73 6b 30 30 31 2f 62 6a 62 61 72 63 6c 61 disk001/bjbarcla
5d00: 2f 67 77 61 2f 69 73 73 75 65 73 2f 6d 74 64 65 /gwa/issues/mtde
5d10: 76 2f 72 61 6e 64 79 2d 73 6c 6f 77 2f 72 65 70 v/randy-slow/rep
5d20: 72 6f 64 75 63 65 2f 71 2e 2e 2e 0a 20 20 28 63 roduce/q.... (c
5d30: 6f 6d 6d 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 ommon:false-on-e
5d40: 78 63 65 70 74 69 6f 6e 20 28 6c 61 6d 62 64 61 xception (lambda
5d50: 20 28 29 20 28 64 69 72 65 63 74 6f 72 79 2d 65 () (directory-e
5d60: 78 69 73 74 73 3f 20 70 61 74 68 2d 73 74 72 69 xists? path-stri
5d70: 6e 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ng)).
5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d90: 20 20 6d 65 73 73 61 67 65 3a 20 28 63 6f 6e 63 message: (conc
5da0: 20 22 55 6e 61 62 6c 65 20 74 6f 20 61 63 63 65 "Unable to acce
5db0: 73 73 20 70 61 74 68 3a 20 22 20 70 61 74 68 2d ss path: " path-
5dc0: 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 20 20 string).
5dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5de0: 20 20 20 20 20 29 29 0a 0a 3b 3b 20 64 6f 65 73 ))..;; does
5df0: 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 65 the directory e
5e00: 78 69 73 74 20 61 6e 64 20 64 6f 20 77 65 20 68 xist and do we h
5e10: 61 76 65 20 77 72 69 74 65 20 61 63 63 65 73 73 ave write access
5e20: 3f 0a 3b 3b 0a 3b 3b 20 20 20 20 72 65 74 75 72 ?.;;.;; retur
5e30: 6e 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 ns the directory
5e40: 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e or #f.;;.(defin
5e50: 65 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 65 63 74 e (common:direct
5e60: 6f 72 79 2d 77 72 69 74 61 62 6c 65 3f 20 70 61 ory-writable? pa
5e70: 74 68 2d 73 74 72 69 6e 67 29 0a 20 20 28 68 61 th-string). (ha
5e80: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
5e90: 20 20 20 65 78 6e 0a 20 20 20 23 66 0a 20 20 20 exn. #f.
5ea0: 28 69 66 20 28 61 6e 64 20 28 64 69 72 65 63 74 (if (and (direct
5eb0: 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 74 68 ory-exists? path
5ec0: 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 20 -string).
5ed0: 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 (file-write
5ee0: 2d 61 63 63 65 73 73 3f 20 70 61 74 68 2d 73 74 -access? path-st
5ef0: 72 69 6e 67 29 29 0a 20 20 20 20 20 20 20 70 61 ring)). pa
5f00: 74 68 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 th-string.
5f10: 20 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d #f)))..;;======
5f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f60: 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 4c 20 .;; M I S C L
5f70: 49 20 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d I S T S.;;======
5f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fc0: 0a 0a 3b 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 ..;; items in li
5fd0: 73 74 61 20 61 72 65 20 6d 61 74 63 68 65 64 20 sta are matched
5fe0: 76 61 6c 75 65 20 61 6e 64 20 70 6f 73 69 74 69 value and positi
5ff0: 6f 6e 20 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 on in listb.;; r
6000: 65 74 75 72 6e 20 74 68 65 20 72 65 6d 61 69 6e eturn the remain
6010: 69 6e 67 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 ing items in lis
6020: 74 62 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 tb or #f.;;.(def
6030: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 ine (common:list
6040: 2d 69 73 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 -is-sublist list
6050: 61 20 6c 69 73 74 62 29 0a 20 20 28 69 66 20 28 a listb). (if (
6060: 6e 75 6c 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 null? lista).
6070: 20 20 20 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 listb ;; all
6080: 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 items in listb a
6090: 72 65 20 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 re "remaining".
60a0: 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e (if (> (len
60b0: 67 74 68 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 gth lista)(lengt
60c0: 68 20 6c 69 73 74 62 29 29 20 0a 09 20 20 23 66 h listb)) .. #f
60d0: 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 .. (let loop ((
60e0: 68 65 64 61 20 28 63 61 72 20 6c 69 73 74 61 29 heda (car lista)
60f0: 29 0a 09 09 20 20 20 20 20 28 74 61 6c 61 20 28 )... (tala (
6100: 63 64 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 cdr lista))...
6110: 20 20 20 28 68 65 64 62 20 28 63 61 72 20 6c 69 (hedb (car li
6120: 73 74 62 29 29 0a 09 09 20 20 20 20 20 28 74 61 stb))... (ta
6130: 6c 62 20 28 63 64 72 20 6c 69 73 74 62 29 29 29 lb (cdr listb)))
6140: 0a 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c .. (if (equal
6150: 3f 20 68 65 64 61 20 68 65 64 62 29 0a 09 09 28 ? heda hedb)...(
6160: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 if (null? tala)
6170: 3b 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 ;; we are done..
6180: 09 20 20 20 20 74 61 6c 62 0a 09 09 20 20 20 20 . talb...
6190: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 61 29 (loop (car tala)
61a0: 0a 09 09 09 20 20 28 63 64 72 20 74 61 6c 61 29 .... (cdr tala)
61b0: 0a 09 09 09 20 20 28 63 61 72 20 74 61 6c 62 29 .... (car talb)
61c0: 0a 09 09 09 20 20 0a 09 09 09 20 20 28 63 64 72 .... .... (cdr
61d0: 20 74 61 6c 62 29 29 29 0a 09 09 23 66 29 29 29 talb)))...#f)))
61e0: 29 29 0a 0a 3b 3b 20 4e 65 65 64 65 64 20 66 6f ))..;; Needed fo
61f0: 72 20 6c 6f 6e 67 20 6c 69 73 74 73 20 74 6f 20 r long lists to
6200: 62 65 20 73 6f 72 74 65 64 20 77 68 65 72 65 20 be sorted where
6210: 28 61 70 70 6c 79 20 6d 61 78 20 2e 2e 2e 20 29 (apply max ... )
6220: 20 64 69 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 dies.;;.(define
6230: 20 28 63 6f 6d 6d 6f 6e 3a 6d 61 78 20 69 6e 6c (common:max inl
6240: 73 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 st). (let loop
6250: 28 28 6d 61 78 2d 76 61 6c 20 28 63 61 72 20 69 ((max-val (car i
6260: 6e 6c 73 74 29 29 0a 09 20 20 20 20 20 28 68 65 nlst)).. (he
6270: 64 20 20 20 20 20 28 63 61 72 20 69 6e 6c 73 74 d (car inlst
6280: 29 29 0a 09 20 20 20 20 20 28 74 61 6c 20 20 20 )).. (tal
6290: 20 20 28 63 64 72 20 69 6e 6c 73 74 29 29 29 0a (cdr inlst))).
62a0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
62b0: 6c 6c 3f 20 74 61 6c 29 29 0a 09 28 6c 6f 6f 70 ll? tal))..(loop
62c0: 20 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 (max hed max-va
62d0: 6c 29 0a 09 20 20 20 20 20 20 28 63 61 72 20 74 l).. (car t
62e0: 61 6c 29 0a 09 20 20 20 20 20 20 28 63 64 72 20 al).. (cdr
62f0: 74 61 6c 29 29 0a 09 28 6d 61 78 20 68 65 64 20 tal))..(max hed
6300: 6d 61 78 2d 76 61 6c 29 29 29 29 0a 0a 3b 3b 20 max-val))))..;;
6310: 67 65 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 get min or max,
6320: 75 73 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e use > for max an
6330: 64 20 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 d < for min, thi
6340: 73 20 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 s works around t
6350: 68 65 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 he limits on app
6360: 6c 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ly.;;.(define (c
6370: 6f 6d 6d 6f 6e 3a 6d 69 6e 2d 6d 61 78 20 63 6f ommon:min-max co
6380: 6d 70 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e mp lst). (if (n
6390: 75 6c 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 ull? lst).
63a0: 23 66 20 3b 3b 20 62 65 74 74 65 72 20 74 68 61 #f ;; better tha
63b0: 6e 20 61 6e 20 65 78 63 65 70 74 69 6f 6e 20 66 n an exception f
63c0: 6f 72 20 6d 79 20 6e 65 65 64 73 0a 20 20 20 20 or my needs.
63d0: 20 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 (fold (lambda
63e0: 28 61 20 62 29 0a 09 20 20 20 20 20 20 28 69 66 (a b).. (if
63f0: 20 28 63 6f 6d 70 20 61 20 62 29 20 61 20 62 29 (comp a b) a b)
6400: 29 0a 09 20 20 20 20 28 63 61 72 20 6c 73 74 29 ).. (car lst)
6410: 0a 09 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b .. lst)))..;;
6420: 20 67 65 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c get min or max,
6430: 20 75 73 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 use > for max a
6440: 6e 64 20 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 nd < for min, th
6450: 69 73 20 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 is works around
6460: 74 68 65 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 the limits on ap
6470: 70 6c 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ply.;;.(define (
6480: 63 6f 6d 6d 6f 6e 3a 73 75 6d 20 6c 73 74 29 0a common:sum lst).
6490: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 (if (null? lst
64a0: 29 0a 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 ). 0.
64b0: 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 (fold (lambda (a
64c0: 20 62 29 0a 09 20 20 20 20 20 20 28 2b 20 61 20 b).. (+ a
64d0: 62 29 29 0a 09 20 20 20 20 28 63 61 72 20 6c 73 b)).. (car ls
64e0: 74 29 0a 09 20 20 20 20 6c 73 74 29 29 29 0a 0a t).. lst)))..
64f0: 3b 3b 20 70 61 74 68 20 6c 69 73 74 20 74 6f 20 ;; path list to
6500: 68 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 0a hash-table tree.
6510: 3b 3b 20 20 20 28 28 61 20 62 20 63 29 28 61 20 ;; ((a b c)(a
6520: 62 20 64 29 28 65 20 62 20 63 29 29 20 3d 3e 20 b d)(e b c)) =>
6530: 28 28 61 20 28 62 20 28 64 29 20 28 63 29 29 29 ((a (b (d) (c)))
6540: 20 28 65 20 28 62 20 28 63 29 29 29 29 0a 3b 3b (e (b (c)))).;;
6550: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
6560: 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 6c 73 74 :list->htree lst
6570: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 68 20 ). (let ((resh
6580: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
6590: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
65a0: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
65b0: 69 6e 6c 73 74 29 0a 20 20 20 20 20 20 20 28 6c inlst). (l
65c0: 65 74 20 6c 6f 6f 70 20 28 28 68 74 20 20 72 65 et loop ((ht re
65d0: 73 68 29 0a 09 09 20 20 28 68 65 64 20 28 63 61 sh)... (hed (ca
65e0: 72 20 69 6e 6c 73 74 29 29 0a 09 09 20 20 28 74 r inlst))... (t
65f0: 61 6c 20 28 63 64 72 20 69 6e 6c 73 74 29 29 29 al (cdr inlst)))
6600: 0a 09 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 .. (if (hash-tab
6610: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
6620: 74 20 68 65 64 20 23 66 29 0a 09 20 20 20 20 20 t hed #f)..
6630: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
6640: 74 61 6c 29 29 0a 09 09 20 28 6c 6f 6f 70 20 28 tal))... (loop (
6650: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 68 hash-table-ref h
6660: 74 20 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 t hed)...
6670: 28 63 61 72 20 74 61 6c 29 0a 09 09 20 20 20 20 (car tal)...
6680: 20 20 20 28 63 64 72 20 74 61 6c 29 29 29 0a 09 (cdr tal)))..
6690: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
66a0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
66b0: 73 65 74 21 20 68 74 20 68 65 64 20 28 6d 61 6b set! ht hed (mak
66c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
66d0: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 68 74 20 (loop ht
66e0: 68 65 64 20 74 61 6c 29 29 29 29 29 0a 20 20 20 hed tal))))).
66f0: 20 20 6c 73 74 29 0a 20 20 20 20 72 65 73 68 29 lst). resh)
6700: 29 0a 0a 0a 0a 0a 0a 28 64 65 66 69 6e 65 20 2a )......(define *
6710: 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 20 20 20 host-loads*
6720: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
6730: 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 able))..;; cache
6740: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
6750: 73 20 66 6f 72 20 65 61 63 68 20 72 75 6e 20 68 s for each run h
6760: 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 ere.(define *env
6770: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
6780: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
6790: 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f 6e 66 e))..;; Testconf
67a0: 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 69 67 ig and runconfig
67b0: 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 69 6e caches. .(defin
67c0: 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 e *testconfigs*
67d0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
67e0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 73 h-table)) ;; tes
67f0: 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 63 6f t-name => testco
6800: 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 nfig.(define *ru
6810: 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 20 nconfigs*
6820: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
6830: 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 20 20 le)) ;; target
6840: 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a 0a => runconfig..
6850: 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 61 63 ;; This is a cac
6860: 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 20 6d he of pre-reqs m
6870: 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 6c et, don't re-cal
6880: 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 72 65 c in cases where
6890: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 61 6d called with sam
68a0: 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 74 68 e params less th
68b0: 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f 6e an.;; five secon
68c0: 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 2a ds ago.(define *
68d0: 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 pre-reqs-met-cac
68e0: 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 he* (make-hash-t
68f0: 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 able))..;; cache
6900: 20 6f 66 20 76 65 72 62 6f 73 69 74 79 20 67 69 of verbosity gi
6910: 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a 28 64 ven string.;;.(d
6920: 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 efine *verbosity
6930: 2d 63 61 63 68 65 2a 20 20 20 20 28 6d 61 6b 65 -cache* (make
6940: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 0a -hash-table))...
6950: 0a 0a 0a 0a 0a 0a 0a 0a 0a 0a 0a 3b 3b 20 65 78 ...........;; ex
6960: 65 63 75 74 65 20 74 68 75 6e 6b 2c 20 72 65 74 ecute thunk, ret
6970: 75 72 6e 20 76 61 6c 75 65 2e 20 20 49 66 20 65 urn value. If e
6980: 78 63 65 70 74 69 6f 6e 20 74 68 72 6f 77 6e 2c xception thrown,
6990: 20 74 72 61 70 20 65 78 63 65 70 74 69 6f 6e 2c trap exception,
69a0: 20 72 65 74 75 72 6e 20 23 66 2c 20 61 6e 64 20 return #f, and
69b0: 65 6d 69 74 20 6e 6f 6e 66 61 74 61 6c 20 63 6f emit nonfatal co
69c0: 6e 64 69 74 69 6f 6e 20 6e 6f 74 65 20 74 6f 20 ndition note to
69d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
69e0: 74 2a 20 2e 0a 3b 3b 20 61 72 67 75 6d 65 6e 74 t* ..;; argument
69f0: 73 20 2d 20 74 68 75 6e 6b 2c 20 6d 65 73 73 61 s - thunk, messa
6a00: 67 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ge.(define (comm
6a10: 6f 6e 3a 66 61 69 6c 2d 73 61 66 65 20 74 68 75 on:fail-safe thu
6a20: 6e 6b 20 77 61 72 6e 69 6e 67 2d 6d 65 73 73 61 nk warning-messa
6a30: 67 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 29 ge-on-exception)
6a40: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
6a50: 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 tions. exn.
6a60: 28 62 65 67 69 6e 0a 20 20 20 20 20 28 64 65 62 (begin. (deb
6a70: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
6a80: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6a90: 74 2a 20 22 6e 6f 74 61 62 6c 65 20 62 75 74 20 t* "notable but
6aa0: 6e 6f 6e 66 61 74 61 6c 20 63 6f 6e 64 69 74 69 nonfatal conditi
6ab0: 6f 6e 20 2d 20 22 77 61 72 6e 69 6e 67 2d 6d 65 on - "warning-me
6ac0: 73 73 61 67 65 2d 6f 6e 2d 65 78 63 65 70 74 69 ssage-on-excepti
6ad0: 6f 6e 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a on). (debug:
6ae0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
6af0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a fault-log-port*.
6b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b10: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 (string-s
6b20: 75 62 73 74 69 74 75 74 65 20 22 5c 6e 3f 45 72 ubstitute "\n?Er
6b30: 72 6f 72 3a 22 20 22 6e 6f 6e 66 61 74 61 6c 20 ror:" "nonfatal
6b40: 63 6f 6e 64 69 74 69 6f 6e 3a 22 0a 20 20 20 20 condition:".
6b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b70: 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 (with-outp
6b80: 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 20 20 20 ut-to-string.
6b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bb0: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
6bc0: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ().
6bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bf0: 20 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d (print-error-m
6c00: 65 73 73 61 67 65 20 65 78 6e 29 20 29 29 29 29 essage exn) ))))
6c10: 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
6c20: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
6c30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
6c40: 20 20 2d 2d 20 63 6f 6e 74 69 6e 75 69 6e 67 20 -- continuing
6c50: 61 66 74 65 72 20 6e 6f 6e 66 61 74 61 6c 20 63 after nonfatal c
6c60: 6f 6e 64 69 74 69 6f 6e 2e 2e 2e 22 29 0a 20 20 ondition...").
6c70: 20 20 20 23 66 29 0a 20 20 20 28 74 68 75 6e 6b #f). (thunk
6c80: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 67 65 74 )))..(define get
6c90: 65 6e 76 20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d env get-environm
6ca0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 29 0a 28 64 ent-variable).(d
6cb0: 65 66 69 6e 65 20 28 73 61 66 65 2d 73 65 74 65 efine (safe-sete
6cc0: 6e 76 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 69 nv key val). (i
6cd0: 66 20 28 6f 72 20 28 73 75 62 73 74 72 69 6e 67 f (or (substring
6ce0: 2d 69 6e 64 65 78 20 22 21 22 20 6b 65 79 29 20 -index "!" key)
6cf0: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
6d00: 20 22 3a 22 20 6b 65 79 29 29 20 3b 3b 20 76 61 ":" key)) ;; va
6d10: 72 69 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 riables containi
6d20: 6e 67 20 3a 20 61 72 65 20 66 6f 72 20 69 6e 74 ng : are for int
6d30: 65 72 6e 61 6c 20 75 73 65 20 61 6e 64 20 63 61 ernal use and ca
6d40: 6e 6e 6f 74 20 62 65 20 65 6e 76 69 72 6f 6e 6d nnot be environm
6d50: 65 6e 74 20 76 61 72 69 61 62 6c 65 73 2e 0a 20 ent variables..
6d60: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6d70: 74 2d 65 72 72 6f 72 20 34 20 2a 64 65 66 61 75 t-error 4 *defau
6d80: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6b lt-log-port* "sk
6d90: 69 70 20 73 65 74 74 69 6e 67 20 69 6e 74 65 72 ip setting inter
6da0: 6e 61 6c 20 75 73 65 20 6f 6e 6c 79 20 76 61 72 nal use only var
6db0: 69 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 6e iables containin
6dc0: 67 20 5c 22 3a 5c 22 20 6f 72 20 73 74 61 72 74 g \":\" or start
6dd0: 69 6e 67 20 77 69 74 68 20 5c 22 21 5c 22 22 29 ing with \"!\"")
6de0: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
6df0: 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 0a 09 20 (string? val)..
6e00: 20 20 20 20 20 20 28 73 74 72 69 6e 67 3f 20 6b (string? k
6e10: 65 79 29 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d ey)).. (handle-
6e20: 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 20 exceptions..
6e30: 20 20 65 78 6e 0a 09 20 20 20 20 20 20 28 64 65 exn.. (de
6e40: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
6e50: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6e60: 6f 72 74 2a 20 22 62 61 64 20 76 61 6c 75 65 20 ort* "bad value
6e70: 66 6f 72 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d for setenv, key=
6e80: 22 20 6b 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 " key ", value="
6e90: 20 76 61 6c 29 0a 09 20 20 20 20 28 73 65 74 65 val).. (sete
6ea0: 6e 76 20 6b 65 79 20 76 61 6c 29 29 0a 09 20 20 nv key val))..
6eb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
6ec0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
6ed0: 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 61 6c g-port* "bad val
6ee0: 75 65 20 66 6f 72 20 73 65 74 65 6e 76 2c 20 6b ue for setenv, k
6ef0: 65 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 6c 75 ey=" key ", valu
6f00: 65 3d 22 20 76 61 6c 29 29 29 29 0a 0a 28 64 65 e=" val))))..(de
6f10: 66 69 6e 65 20 68 6f 6d 65 20 28 67 65 74 65 6e fine home (geten
6f20: 76 20 22 48 4f 4d 45 22 29 29 0a 28 64 65 66 69 v "HOME")).(defi
6f30: 6e 65 20 75 73 65 72 20 28 67 65 74 65 6e 76 20 ne user (getenv
6f40: 22 55 53 45 52 22 29 29 0a 0a 3b 3b 20 70 75 74 "USER"))..;; put
6f50: 20 61 6e 79 20 63 68 61 6e 67 65 64 20 65 6e 76 any changed env
6f60: 69 72 6f 6e 6d 65 6e 74 20 76 61 72 69 61 62 6c ironment variabl
6f70: 65 73 20 62 61 63 6b 20 74 6f 20 68 6f 77 20 74 es back to how t
6f80: 68 65 79 20 77 65 72 65 20 2d 20 54 4f 44 4f 20 hey were - TODO
6f90: 2d 20 74 75 72 6e 20 74 68 69 73 20 69 6e 74 6f - turn this into
6fa0: 20 73 6f 6d 65 20 73 6f 72 74 20 6f 66 20 77 69 some sort of wi
6fb0: 74 68 2d 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d th-.(define (com
6fc0: 6d 6f 6e 3a 73 65 74 2d 76 61 72 73 2d 62 61 63 mon:set-vars-bac
6fd0: 6b 20 61 6c 6c 2d 76 61 72 73 29 0a 20 20 28 66 k all-vars). (f
6fe0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
6ff0: 6d 62 64 61 20 28 76 61 72 64 61 74 29 0a 20 20 mbda (vardat).
7000: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 (let ((var
7010: 28 63 61 72 20 76 61 72 64 61 74 29 29 0a 09 20 (car vardat))..
7020: 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 76 61 (val (cdr va
7030: 72 64 61 74 29 29 29 0a 09 20 28 69 66 20 28 6e rdat))).. (if (n
7040: 6f 74 20 28 65 71 75 61 6c 3f 20 28 67 65 74 2d ot (equal? (get-
7050: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
7060: 61 62 6c 65 20 76 61 72 29 20 76 61 6c 29 29 0a able var) val)).
7070: 09 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 . (handle-ex
7080: 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 20 20 20 ceptions..
7090: 65 78 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 exn.. (debu
70a0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
70b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
70c0: 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 t* "Failed to se
70d0: 74 20 22 20 76 61 72 20 22 20 74 6f 20 22 20 76 t " var " to " v
70e0: 61 6c 29 0a 09 20 20 20 20 20 20 28 73 65 74 65 al).. (sete
70f0: 6e 76 20 76 61 72 20 76 61 6c 29 29 29 29 29 0a nv var val))))).
7100: 20 20 20 20 20 61 6c 6c 2d 76 61 72 73 29 29 0a all-vars)).
7110: 20 20 0a 20 20 3b 3b 20 72 65 74 75 72 6e 73 20 . ;; returns
7120: 6c 69 73 74 20 6f 66 20 66 64 20 63 6f 75 6e 74 list of fd count
7130: 2c 20 73 6f 63 6b 65 74 20 63 6f 75 6e 74 0a 28 , socket count.(
7140: 64 65 66 69 6e 65 20 28 67 65 74 2d 66 69 6c 65 define (get-file
7150: 2d 64 65 73 63 72 69 70 74 6f 72 2d 63 6f 75 6e -descriptor-coun
7160: 74 20 23 21 6b 65 79 20 20 28 70 69 64 20 28 63 t #!key (pid (c
7170: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
7180: 64 20 29 29 29 0a 20 20 28 6c 69 73 74 0a 20 20 d ))). (list.
7190: 20 20 28 6c 65 6e 67 74 68 20 28 67 6c 6f 62 20 (length (glob
71a0: 28 63 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 (conc "/proc/" p
71b0: 69 64 20 22 2f 66 64 2f 2a 22 29 29 29 0a 20 20 id "/fd/*"))).
71c0: 20 20 28 6c 65 6e 67 74 68 20 20 28 66 69 6c 74 (length (filt
71d0: 65 72 20 69 64 65 6e 74 69 74 79 20 28 6d 61 70 er identity (map
71e0: 20 73 6f 63 6b 65 74 3f 20 28 67 6c 6f 62 20 28 socket? (glob (
71f0: 63 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 conc "/proc/" pi
7200: 64 20 22 2f 66 64 2f 2a 22 29 29 29 29 29 0a 20 d "/fd/*"))))).
7210: 20 29 0a 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 ).)..(define *c
7220: 6f 6d 6d 6f 6e 3a 6c 6f 67 70 72 6f 2d 65 78 69 ommon:logpro-exi
7230: 74 2d 63 6f 64 65 2d 3e 73 74 61 74 75 73 2d 73 t-code->status-s
7240: 79 6d 2d 61 6c 69 73 74 2a 0a 20 20 27 28 20 28 ym-alist*. '( (
7250: 20 30 20 2e 20 70 61 73 73 20 29 0a 20 20 20 20 0 . pass ).
7260: 20 28 20 31 20 2e 20 66 61 69 6c 20 29 0a 20 20 ( 1 . fail ).
7270: 20 20 20 28 20 32 20 2e 20 77 61 72 6e 20 29 0a ( 2 . warn ).
7280: 20 20 20 20 20 28 20 33 20 2e 20 63 68 65 63 6b ( 3 . check
7290: 20 29 0a 20 20 20 20 20 28 20 34 20 2e 20 77 61 ). ( 4 . wa
72a0: 69 76 65 64 20 29 0a 20 20 20 20 20 28 20 35 20 ived ). ( 5
72b0: 2e 20 61 62 6f 72 74 20 29 0a 20 20 20 20 20 28 . abort ). (
72c0: 20 36 20 2e 20 73 6b 69 70 20 29 29 29 0a 0a 28 6 . skip )))..(
72d0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
72e0: 6f 67 70 72 6f 2d 65 78 69 74 2d 63 6f 64 65 2d ogpro-exit-code-
72f0: 3e 73 74 61 74 75 73 2d 73 79 6d 20 65 78 69 74 >status-sym exit
7300: 2d 63 6f 64 65 29 0a 20 20 28 6f 72 20 28 61 6c -code). (or (al
7310: 69 73 74 2d 72 65 66 20 65 78 69 74 2d 63 6f 64 ist-ref exit-cod
7320: 65 20 2a 63 6f 6d 6d 6f 6e 3a 6c 6f 67 70 72 6f e *common:logpro
7330: 2d 65 78 69 74 2d 63 6f 64 65 2d 3e 73 74 61 74 -exit-code->stat
7340: 75 73 2d 73 79 6d 2d 61 6c 69 73 74 2a 29 20 27 us-sym-alist*) '
7350: 66 61 69 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 fail))..(define
7360: 28 63 6f 6d 6d 6f 6e 3a 77 6f 72 73 65 2d 73 74 (common:worse-st
7370: 61 74 75 73 2d 73 79 6d 20 73 73 31 20 73 73 32 atus-sym ss1 ss2
7380: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
7390: 73 74 61 74 75 73 2d 73 79 6d 73 2d 72 65 6d 61 status-syms-rema
73a0: 69 6e 69 6e 67 20 27 28 61 62 6f 72 74 20 66 61 ining '(abort fa
73b0: 69 6c 20 63 68 65 63 6b 20 73 6b 69 70 20 77 61 il check skip wa
73c0: 72 6e 20 77 61 69 76 65 64 20 70 61 73 73 29 29 rn waived pass))
73d0: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
73e0: 20 28 28 6e 75 6c 6c 3f 20 73 74 61 74 75 73 2d ((null? status-
73f0: 73 79 6d 73 2d 72 65 6d 61 69 6e 69 6e 67 29 0a syms-remaining).
7400: 20 20 20 20 20 20 27 66 61 69 6c 29 0a 20 20 20 'fail).
7410: 20 20 28 28 65 71 3f 20 28 63 61 72 20 73 74 61 ((eq? (car sta
7420: 74 75 73 2d 73 79 6d 73 2d 72 65 6d 61 69 6e 69 tus-syms-remaini
7430: 6e 67 29 20 73 73 31 29 0a 20 20 20 20 20 20 73 ng) ss1). s
7440: 73 31 29 0a 20 20 20 20 20 28 28 65 71 3f 20 28 s1). ((eq? (
7450: 63 61 72 20 73 74 61 74 75 73 2d 73 79 6d 73 2d car status-syms-
7460: 72 65 6d 61 69 6e 69 6e 67 29 20 73 73 32 29 0a remaining) ss2).
7470: 20 20 20 20 20 20 73 73 32 29 0a 20 20 20 20 20 ss2).
7480: 28 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 6f 6f (else. (loo
7490: 70 20 28 63 64 72 20 73 74 61 74 75 73 2d 73 79 p (cdr status-sy
74a0: 6d 73 2d 72 65 6d 61 69 6e 69 6e 67 29 29 29 29 ms-remaining))))
74b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
74c0: 6d 6f 6e 3a 73 74 65 70 73 2d 63 61 6e 2d 70 72 mon:steps-can-pr
74d0: 6f 63 65 65 64 2d 67 69 76 65 6e 2d 73 74 61 74 oceed-given-stat
74e0: 75 73 2d 73 79 6d 20 73 74 61 74 75 73 2d 73 79 us-sym status-sy
74f0: 6d 29 0a 20 20 28 69 66 20 28 6d 65 6d 62 65 72 m). (if (member
7500: 20 73 74 61 74 75 73 2d 73 79 6d 20 27 28 77 61 status-sym '(wa
7510: 72 6e 20 77 61 69 76 65 64 20 70 61 73 73 29 29 rn waived pass))
7520: 0a 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 . #t.
7530: 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 #f))..(define (s
7540: 74 61 74 75 73 2d 73 79 6d 2d 3e 73 74 72 69 6e tatus-sym->strin
7550: 67 20 73 74 61 74 75 73 2d 73 79 6d 29 0a 20 20 g status-sym).
7560: 28 63 61 73 65 20 73 74 61 74 75 73 2d 73 79 6d (case status-sym
7570: 0a 20 20 20 20 20 20 28 28 70 61 73 73 29 20 22 . ((pass) "
7580: 50 41 53 53 22 29 0a 20 20 20 20 28 28 66 61 69 PASS"). ((fai
7590: 6c 29 20 22 46 41 49 4c 22 29 0a 20 20 20 20 28 l) "FAIL"). (
75a0: 28 77 61 72 6e 29 20 22 57 41 52 4e 22 29 0a 20 (warn) "WARN").
75b0: 20 20 20 28 28 63 68 65 63 6b 29 20 22 43 48 45 ((check) "CHE
75c0: 43 4b 22 29 0a 20 20 20 20 28 28 77 61 69 76 65 CK"). ((waive
75d0: 64 29 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 d) "WAIVED").
75e0: 20 28 28 61 62 6f 72 74 29 20 22 41 42 4f 52 54 ((abort) "ABORT
75f0: 22 29 0a 20 20 20 20 28 28 73 6b 69 70 29 20 22 "). ((skip) "
7600: 53 4b 49 50 22 29 0a 20 20 20 20 28 65 6c 73 65 SKIP"). (else
7610: 20 22 46 41 49 4c 22 29 29 29 0a 0a 28 64 65 66 "FAIL")))..(def
7620: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 67 70 ine (common:logp
7630: 72 6f 2d 65 78 69 74 2d 63 6f 64 65 2d 3e 74 65 ro-exit-code->te
7640: 73 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 st-status exit-c
7650: 6f 64 65 29 0a 20 20 28 73 74 61 74 75 73 2d 73 ode). (status-s
7660: 79 6d 2d 3e 73 74 72 69 6e 67 20 28 63 6f 6d 6d ym->string (comm
7670: 6f 6e 3a 6c 6f 67 70 72 6f 2d 65 78 69 74 2d 63 on:logpro-exit-c
7680: 6f 64 65 2d 3e 73 74 61 74 75 73 2d 73 79 6d 20 ode->status-sym
7690: 65 78 69 74 2d 63 6f 64 65 29 29 29 0a 0a 28 64 exit-code)))..(d
76a0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c efine (common:cl
76b0: 65 61 72 2d 63 61 63 68 65 73 29 0a 20 20 28 73 ear-caches). (s
76c0: 65 74 21 20 2a 74 61 72 67 65 74 2a 20 20 20 20 et! *target*
76d0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
76e0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
76f0: 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 et! *keys*
7700: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
7710: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
7720: 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a 20 20 20 et! *keyvals*
7730: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
7740: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
7750: 65 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 61 74 et! *toptest-pat
7760: 68 73 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 hs* (make-h
7770: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
7780: 65 74 21 20 2a 74 65 73 74 2d 70 61 74 68 73 2a et! *test-paths*
7790: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
77a0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
77b0: 65 74 21 20 2a 74 65 73 74 2d 69 64 73 2a 20 20 et! *test-ids*
77c0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
77d0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
77e0: 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 et! *test-info*
77f0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
7800: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
7810: 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f 2d 63 61 et! *run-info-ca
7820: 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 che* (make-h
7830: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
7840: 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 et! *env-vars-by
7850: 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 -run-id* (make-h
7860: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
7870: 65 74 21 20 2a 74 65 73 74 2d 69 64 2d 63 61 63 et! *test-id-cac
7880: 68 65 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 he* (make-h
7890: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a 3b 3b ash-table)))..;;
78a0: 20 47 65 6e 65 72 69 63 20 73 74 72 69 6e 67 20 Generic string
78b0: 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 database.(define
78c0: 20 73 64 62 3a 71 72 79 20 23 66 29 20 3b 3b 20 sdb:qry #f) ;;
78d0: 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 29 29 20 (make-sdb:qry))
78e0: 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 0a 3b 3b ;; 'init #f).;;
78f0: 20 47 65 6e 65 72 69 63 20 70 61 74 68 20 64 61 Generic path da
7900: 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 20 2a tabase.(define *
7910: 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e fdb* #f)..(defin
7920: 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 20 e *last-launch*
7930: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
7940: 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 20 74 68 )) ;; use for th
7950: 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 6c 61 75 rottling the lau
7960: 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 6c 64 20 nch rate. Would
7970: 62 65 20 62 65 74 74 65 72 20 74 6f 20 75 73 65 be better to use
7980: 20 74 68 65 20 64 62 20 61 6e 64 20 6c 61 73 74 the db and last
7990: 20 74 69 6d 65 20 6f 66 20 61 20 74 65 73 74 20 time of a test
79a0: 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 74 61 74 in LAUNCHED stat
79b0: 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d e...;;==========
79c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
7a00: 56 20 45 20 52 20 53 20 49 20 4f 20 4e 0a 3b 3b V E R S I O N.;;
7a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a50: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
7a60: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c (common:get-full
7a70: 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 6f 6e -version). (con
7a80: 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 c megatest-versi
7a90: 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 2d on "-" megatest-
7aa0: 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 0a 28 fossil-hash))..(
7ab0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 define (common:v
7ac0: 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 ersion-signature
7ad0: 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 74 65 ). (conc megate
7ae0: 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 28 st-version "-" (
7af0: 73 75 62 73 74 72 69 6e 67 20 6d 65 67 61 74 65 substring megate
7b00: 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 20 30 st-fossil-hash 0
7b10: 20 34 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 4)))...(define
7b20: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 79 6e 63 (common:get-sync
7b30: 2d 6c 6f 63 6b 2d 66 69 6c 65 70 61 74 68 29 0a -lock-filepath).
7b40: 20 20 28 6c 65 74 2a 20 28 28 74 6d 70 2d 61 72 (let* ((tmp-ar
7b50: 65 61 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 ea (common:g
7b60: 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 et-db-tmp-area))
7b70: 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 63 6b 66 . (lockf
7b80: 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 74 6d ile (conc tm
7b90: 70 2d 61 72 65 61 20 22 2f 6d 65 67 61 74 65 73 p-area "/megates
7ba0: 74 2e 64 62 2e 73 79 6e 63 2d 6c 6f 63 6b 22 29 t.db.sync-lock")
7bb0: 29 29 0a 20 20 20 20 6c 6f 63 6b 66 69 6c 65 29 )). lockfile)
7bc0: 29 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ). .;;=======
7bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7c10: 3b 3b 20 55 20 53 20 45 20 46 20 55 20 4c 20 20 ;; U S E F U L
7c20: 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d S T U F F.;;===
7c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c70: 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 ===..;; convert
7c80: 74 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 things to an ali
7c90: 73 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 st or assoc list
7ca0: 2c 20 23 66 20 67 65 74 73 20 63 6f 6e 76 65 72 , #f gets conver
7cb0: 74 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 ted to "".;;.(de
7cc0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d fine (common:to-
7cd0: 61 6c 69 73 74 20 64 61 74 29 0a 20 20 28 63 6f alist dat). (co
7ce0: 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 61 nd. ((list? da
7cf0: 74 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e t) (map common
7d00: 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 0a :to-alist dat)).
7d10: 20 20 20 28 28 76 65 63 74 6f 72 3f 20 64 61 74 ((vector? dat
7d20: 29 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f ). (map commo
7d30: 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 n:to-alist (vect
7d40: 6f 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 0a or->list dat))).
7d50: 20 20 20 28 28 70 61 69 72 3f 20 64 61 74 29 0a ((pair? dat).
7d60: 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f (cons (commo
7d70: 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 n:to-alist (car
7d80: 64 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e dat)).. (common
7d90: 3a 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 64 :to-alist (cdr d
7da0: 61 74 29 29 29 29 0a 20 20 20 28 28 68 61 73 68 at)))). ((hash
7db0: 2d 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 -table? dat).
7dc0: 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d (map common:to-
7dd0: 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c alist (hash-tabl
7de0: 65 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 29 0a e->alist dat))).
7df0: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 69 66 (else. (if
7e00: 20 64 61 74 0a 09 64 61 74 0a 09 22 22 29 29 29 dat..dat.."")))
7e10: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
7e20: 6f 6e 3a 61 6c 69 73 74 2d 72 65 66 2f 64 65 66 on:alist-ref/def
7e30: 61 75 6c 74 20 6b 65 79 20 61 6c 69 73 74 20 64 ault key alist d
7e40: 65 66 61 75 6c 74 29 0a 20 20 28 6f 72 20 28 61 efault). (or (a
7e50: 6c 69 73 74 2d 72 65 66 20 6b 65 79 20 61 6c 69 list-ref key ali
7e60: 73 74 29 20 64 65 66 61 75 6c 74 29 29 0a 0a 28 st) default))..(
7e70: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
7e80: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 77 ow-noise-print w
7e90: 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 0a 20 aitval . keys).
7ea0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 (let* ((key
7eb0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
7ec0: 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 perse (map conc
7ed0: 6b 65 79 73 29 20 22 2d 22 20 29 29 0a 09 20 28 keys) "-" )).. (
7ee0: 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d 74 lasttime (hash-t
7ef0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7f00: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
7f10: 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 63 75 72 * key 0)).. (cur
7f20: 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 rtime (current-s
7f30: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 econds))). (i
7f40: 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 f (> (- currtime
7f50: 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 lasttime) waitv
7f60: 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 al)..(begin.. (
7f70: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
7f80: 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a *common:denoise*
7f90: 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a 09 key currtime)..
7fa0: 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 #t)..#f)))..(d
7fb0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
7fc0: 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a t-megatest-exe).
7fd0: 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d (or (getenv "M
7fe0: 54 5f 4d 45 47 41 54 45 53 54 22 29 20 22 6d 65 T_MEGATEST") "me
7ff0: 67 61 74 65 73 74 22 29 29 0a 0a 28 64 65 66 69 gatest"))..(defi
8000: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d ne (common:read-
8010: 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 69 encoded-string i
8020: 6e 73 74 72 29 0a 20 20 28 68 61 6e 64 6c 65 2d nstr). (handle-
8030: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
8040: 6e 0a 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 n. (handle-exc
8050: 65 70 74 69 6f 6e 73 0a 20 20 20 20 65 78 6e 0a eptions. exn.
8060: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
8070: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
8080: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
8090: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 65 69 76 og-port* "receiv
80a0: 65 64 20 62 61 64 20 65 6e 63 6f 64 65 64 20 73 ed bad encoded s
80b0: 74 72 69 6e 67 20 5c 22 22 20 69 6e 73 74 72 20 tring \"" instr
80c0: 22 5c 22 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 "\", message: "
80d0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
80e0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
80f0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
8100: 29 29 0a 20 20 20 20 20 20 28 70 72 69 6e 74 2d )). (print-
8110: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
8120: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
8130: 0a 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 28 . #f). (
8140: 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 read (open-input
8150: 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 34 3a -string (base64:
8160: 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e base64-decode in
8170: 73 74 72 29 29 29 29 0a 20 20 20 28 72 65 61 64 str)))). (read
8180: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 (open-input-str
8190: 69 6e 67 20 28 7a 33 3a 64 65 63 6f 64 65 2d 62 ing (z3:decode-b
81a0: 75 66 66 65 72 20 28 62 61 73 65 36 34 3a 62 61 uffer (base64:ba
81b0: 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 74 se64-decode inst
81c0: 72 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d r))))))..;;=====
81d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8210: 3d 0a 3b 3b 20 43 6f 6e 66 69 67 66 20 65 78 74 =.;; Configf ext
8220: 65 6e 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d entions.;;======
8230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8270: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 77 ..(define (get-w
8280: 69 74 68 2d 64 65 66 61 75 6c 74 20 76 61 6c 20 ith-default val
8290: 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 default). (let
82a0: 28 28 76 61 6c 20 28 61 72 67 73 3a 67 65 74 2d ((val (args:get-
82b0: 61 72 67 20 76 61 6c 29 29 29 0a 20 20 20 20 28 arg val))). (
82c0: 69 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 75 if val val defau
82d0: 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 lt)))..(define (
82e0: 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 6b 65 assoc/default ke
82f0: 79 20 6c 73 74 20 2e 20 64 65 66 61 75 6c 74 29 y lst . default)
8300: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 61 . (let ((res (a
8310: 73 73 6f 63 20 6b 65 79 20 6c 73 74 29 29 29 0a ssoc key lst))).
8320: 20 20 20 20 28 69 66 20 72 65 73 20 28 63 61 64 (if res (cad
8330: 72 20 72 65 73 29 28 69 66 20 28 6e 75 6c 6c 3f r res)(if (null?
8340: 20 64 65 66 61 75 6c 74 29 20 23 66 20 28 63 61 default) #f (ca
8350: 72 20 64 65 66 61 75 6c 74 29 29 29 29 29 0a 0a r default)))))..
8360: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
8370: 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 get-testsuite-na
8380: 6d 65 29 0a 20 20 28 6f 72 20 28 63 6f 6e 66 69 me). (or (confi
8390: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
83a0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 61 gdat* "setup" "a
83b0: 72 65 61 2d 6e 61 6d 65 22 29 20 3b 3b 20 6d 65 rea-name") ;; me
83c0: 67 61 74 65 73 74 20 69 73 20 61 20 66 6c 65 78 gatest is a flex
83d0: 69 62 6c 65 20 74 6f 6f 6c 2c 20 74 65 73 74 73 ible tool, tests
83e0: 75 69 74 65 20 69 73 20 74 6f 6f 20 6c 69 6d 69 uite is too limi
83f0: 74 69 6e 67 20 61 20 64 65 73 63 72 69 70 74 69 ting a descripti
8400: 6f 6e 2e 0a 20 20 20 20 20 20 28 63 6f 6e 66 69 on.. (confi
8410: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
8420: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 74 gdat* "setup" "t
8430: 65 73 74 73 75 69 74 65 22 20 29 0a 20 20 20 20 estsuite" ).
8440: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 (getenv "MT_TE
8450: 53 54 53 55 49 54 45 5f 4e 41 4d 45 22 29 0a 20 STSUITE_NAME").
8460: 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
8470: 3f 20 2a 74 6f 70 70 61 74 68 2a 20 29 0a 20 20 ? *toppath* ).
8480: 20 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 6d (pathnam
8490: 65 2d 66 69 6c 65 20 2a 74 6f 70 70 61 74 68 2a e-file *toppath*
84a0: 29 0a 20 20 20 20 20 20 20 20 20 20 23 66 29 29 ). #f))
84b0: 29 20 3b 3b 20 28 70 61 74 68 6e 61 6d 65 2d 66 ) ;; (pathname-f
84c0: 69 6c 65 20 28 63 75 72 72 65 6e 74 2d 64 69 72 ile (current-dir
84d0: 65 63 74 6f 72 79 29 29 29 29 29 0a 0a 28 64 65 ectory)))))..(de
84e0: 66 69 6e 65 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d fine common:get-
84f0: 61 72 65 61 2d 6e 61 6d 65 20 63 6f 6d 6d 6f 6e area-name common
8500: 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e :get-testsuite-n
8510: 61 6d 65 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ame)..(define (c
8520: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 ommon:get-db-tmp
8530: 2d 61 72 65 61 20 2e 20 6a 75 6e 6b 29 0a 20 20 -area . junk).
8540: 28 69 66 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 (if *db-cache-pa
8550: 74 68 2a 0a 20 20 20 20 20 20 2a 64 62 2d 63 61 th*. *db-ca
8560: 63 68 65 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 che-path*.
8570: 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 3b 3b (if *toppath* ;;
8580: 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 common:get-crea
8590: 74 65 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 te-writeable-dir
85a0: 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 .. (handle-exce
85b0: 70 74 69 6f 6e 73 0a 09 20 20 20 20 20 20 65 78 ptions.. ex
85c0: 6e 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a n.. (begin.
85d0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
85e0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
85f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 6f 75 6c 64 log-port* "Could
8600: 6e 27 74 20 63 72 65 61 74 65 20 70 61 74 68 20 n't create path
8610: 74 6f 20 22 20 2a 64 62 2d 63 61 63 68 65 2d 70 to " *db-cache-p
8620: 61 74 68 2a 29 0a 09 09 28 65 78 69 74 20 31 29 ath*)...(exit 1)
8630: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 64 62 ).. (let ((db
8640: 70 61 74 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 path (common:get
8650: 2d 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 6c -create-writeabl
8660: 65 2d 64 69 72 0a 09 09 09 20 20 20 28 6c 69 73 e-dir.... (lis
8670: 74 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 t (conc "/tmp/"
8680: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
8690: 6d 65 29 0a 09 09 09 09 20 20 20 20 20 20 20 22 me)..... "
86a0: 2f 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 /megatest_locald
86b0: 62 2f 22 0a 09 09 09 09 20 20 20 20 20 20 20 28 b/"..... (
86c0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
86d0: 75 69 74 65 2d 6e 61 6d 65 29 20 22 2f 22 0a 09 uite-name) "/"..
86e0: 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
86f0: 67 2d 74 72 61 6e 73 6c 61 74 65 20 2a 74 6f 70 g-translate *top
8700: 70 61 74 68 2a 20 22 2f 22 20 22 2e 22 29 29 29 path* "/" ".")))
8710: 29 29 29 20 3b 3b 20 20 23 74 29 29 29 29 0a 09 ))) ;; #t))))..
8720: 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d (set! *db-
8730: 63 61 63 68 65 2d 70 61 74 68 2a 20 64 62 70 61 cache-path* dbpa
8740: 74 68 29 0a 09 20 20 20 20 20 20 64 62 70 61 74 th).. dbpat
8750: 68 29 29 0a 09 20 20 23 66 29 29 29 0a 0a 0a 3b h)).. #f)))...;
8760: 3b 20 70 75 6c 6c 65 64 20 66 72 6f 6d 20 63 6f ; pulled from co
8770: 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d mmon_records.scm
8780: 0a 0a 3b 3b 20 67 6c 6f 62 61 6c 73 20 2d 20 6d ..;; globals - m
8790: 6f 64 75 6c 65 73 20 74 68 61 74 20 69 6e 63 6c odules that incl
87a0: 75 64 65 20 74 68 69 73 20 6e 65 65 64 20 74 68 ude this need th
87b0: 65 73 65 20 68 65 72 65 0a 28 64 65 66 69 6e 65 ese here.(define
87c0: 20 2a 6c 6f 67 67 69 6e 67 2a 20 23 66 29 0a 28 *logging* #f).(
87d0: 64 65 66 69 6e 65 20 2a 66 75 6e 63 74 69 6f 6e define *function
87e0: 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 s* (make-hash-ta
87f0: 62 6c 65 29 29 20 3b 3b 20 73 79 6d 62 6f 6c 20 ble)) ;; symbol
8800: 3d 3e 20 66 6e 20 23 23 23 20 54 45 4d 50 4f 52 => fn ### TEMPOR
8810: 41 52 59 21 21 21 0a 3b 3b 20 28 64 65 66 69 6e ARY!!!.;; (defin
8820: 65 20 2a 74 6f 70 70 61 74 68 2a 20 23 66 29 0a e *toppath* #f).
8830: 28 64 65 66 69 6e 65 20 2a 74 72 61 6e 73 70 6f (define *transpo
8840: 72 74 2d 74 79 70 65 2a 20 27 68 74 74 70 29 0a rt-type* 'http).
8850: 0a 23 3b 28 64 65 66 69 6e 65 20 28 65 78 65 63 .#;(define (exec
8860: 2d 66 6e 20 66 6e 20 2e 20 70 61 72 61 6d 73 29 -fn fn . params)
8870: 0a 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 . (if (hash-tab
8880: 6c 65 2d 65 78 69 73 74 73 3f 20 2a 66 75 6e 63 le-exists? *func
8890: 74 69 6f 6e 73 2a 20 66 6e 29 0a 20 20 20 20 20 tions* fn).
88a0: 20 28 61 70 70 6c 79 20 28 68 61 73 68 2d 74 61 (apply (hash-ta
88b0: 62 6c 65 2d 72 65 66 20 2a 66 75 6e 63 74 69 6f ble-ref *functio
88c0: 6e 73 2a 20 66 6e 29 20 70 61 72 61 6d 73 29 0a ns* fn) params).
88d0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 (begin..(d
88e0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
88f0: 20 30 20 22 65 78 65 63 2d 66 6e 20 22 20 66 6e 0 "exec-fn " fn
8900: 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 " not found")..
8910: 23 66 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 #f)))..#;(define
8920: 20 28 73 65 74 2d 66 6e 20 66 6e 2d 6e 61 6d 65 (set-fn fn-name
8930: 20 66 6e 29 0a 20 20 28 68 61 73 68 2d 74 61 62 fn). (hash-tab
8940: 6c 65 2d 73 65 74 21 20 2a 66 75 6e 63 74 69 6f le-set! *functio
8950: 6e 73 2a 20 66 6e 2d 6e 61 6d 65 20 66 6e 29 29 ns* fn-name fn))
8960: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 61 6c 74 64 ..(include "altd
8970: 62 2e 73 63 6d 22 29 0a 0a 0a 3b 3b 20 50 75 6c b.scm")...;; Pul
8980: 6c 65 64 20 66 72 6f 6d 20 68 74 74 70 2d 74 72 led from http-tr
8990: 61 6e 73 70 6f 72 74 2e 73 63 6d 0a 0a 28 64 65 ansport.scm..(de
89a0: 66 69 6e 65 20 28 6d 61 6b 65 2d 68 74 74 70 2d fine (make-http-
89b0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
89c0: 2d 64 61 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f -dat)(make-vecto
89d0: 72 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 68 r 6)).(define (h
89e0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
89f0: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 rver-dat-get-ifa
8a00: 63 65 20 20 20 20 20 20 20 20 20 76 65 63 29 20 ce vec)
8a10: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
8a20: 76 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 20 vec 0)).(define
8a30: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
8a40: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 server-dat-get-p
8a50: 6f 72 74 20 20 20 20 20 20 20 20 20 20 76 65 63 ort vec
8a60: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
8a70: 20 20 76 65 63 20 31 29 29 0a 28 64 65 66 69 6e vec 1)).(defin
8a80: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
8a90: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
8aa0: 2d 61 70 69 2d 75 72 69 20 20 20 20 20 20 20 76 -api-uri v
8ab0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
8ac0: 65 66 20 20 76 65 63 20 32 29 29 0a 28 64 65 66 ef vec 2)).(def
8ad0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
8ae0: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
8af0: 65 74 2d 61 70 69 2d 75 72 6c 20 20 20 20 20 20 et-api-url
8b00: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
8b10: 2d 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 64 -ref vec 3)).(d
8b20: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
8b30: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
8b40: 2d 67 65 74 2d 61 70 69 2d 72 65 71 20 20 20 20 -get-api-req
8b50: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
8b60: 6f 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a or-ref vec 4)).
8b70: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
8b80: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
8b90: 61 74 2d 67 65 74 2d 6c 61 73 74 2d 61 63 63 65 at-get-last-acce
8ba0: 73 73 20 20 20 76 65 63 29 20 20 20 20 28 76 65 ss vec) (ve
8bb0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 29 ctor-ref vec 5)
8bc0: 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ).(define (http-
8bd0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
8be0: 2d 64 61 74 2d 67 65 74 2d 73 6f 63 6b 65 74 20 -dat-get-socket
8bf0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
8c00: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
8c10: 36 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 6))..(define (ht
8c20: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
8c30: 76 65 72 2d 64 61 74 2d 6d 61 6b 65 2d 75 72 6c ver-dat-make-url
8c40: 20 76 65 63 29 0a 20 20 28 69 66 20 28 61 6e 64 vec). (if (and
8c50: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
8c60: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
8c70: 69 66 61 63 65 20 76 65 63 29 0a 09 20 20 20 28 iface vec).. (
8c80: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
8c90: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f erver-dat-get-po
8ca0: 72 74 20 20 76 65 63 29 29 0a 20 20 20 20 20 20 rt vec)).
8cb0: 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 (conc "http://"
8cc0: 0a 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e .. (http-tran
8cd0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
8ce0: 2d 67 65 74 2d 69 66 61 63 65 20 76 65 63 29 0a -get-iface vec).
8cf0: 09 20 20 20 20 22 3a 22 0a 09 20 20 20 20 28 68 . ":".. (h
8d00: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
8d10: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f 72 rver-dat-get-por
8d20: 74 20 20 76 65 63 29 29 0a 20 20 20 20 20 20 23 t vec)). #
8d30: 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 f))..(define (ht
8d40: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
8d50: 76 65 72 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c ver-dat-update-l
8d60: 61 73 74 2d 61 63 63 65 73 73 20 76 65 63 29 0a ast-access vec).
8d70: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 76 (if (vector? v
8d80: 65 63 29 0a 20 20 20 20 20 20 28 76 65 63 74 6f ec). (vecto
8d90: 72 2d 73 65 74 21 20 76 65 63 20 35 20 28 63 75 r-set! vec 5 (cu
8da0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
8db0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 70 (begin..(p
8dc0: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
8dd0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
8de0: 6f 72 74 29 29 0a 09 28 64 65 62 75 67 3a 70 72 ort))..(debug:pr
8df0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 28 63 75 72 int-error 0 (cur
8e00: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
8e10: 20 22 63 61 6c 6c 20 74 6f 20 68 74 74 70 2d 74 "call to http-t
8e20: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
8e30: 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d dat-update-last-
8e40: 61 63 63 65 73 73 20 77 69 74 68 20 6e 6f 6e 2d access with non-
8e50: 76 65 63 74 6f 72 21 21 22 29 29 29 29 0a 0a 3b vector!!"))))..;
8e60: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ea0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 3d 3d 3d =======.;;.;;===
8eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ef0: 3d 3d 3d 0a 0a 0a 3b 3b 20 61 6c 6c 6f 77 20 74 ===...;; allow t
8f00: 68 65 73 65 20 71 75 65 72 69 65 73 20 74 68 72 hese queries thr
8f10: 6f 75 67 68 20 77 69 74 68 6f 75 74 20 73 74 61 ough without sta
8f20: 72 74 69 6e 67 20 61 20 73 65 72 76 65 72 0a 3b rting a server.;
8f30: 3b 0a 28 64 65 66 69 6e 65 20 61 70 69 3a 72 65 ;.(define api:re
8f40: 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 0a ad-only-queries.
8f50: 20 20 27 28 67 65 74 2d 6b 65 79 2d 76 61 6c 2d '(get-key-val-
8f60: 70 61 69 72 73 0a 20 20 20 20 67 65 74 2d 76 61 pairs. get-va
8f70: 72 0a 20 20 20 20 67 65 74 2d 6b 65 79 73 0a 20 r. get-keys.
8f80: 20 20 20 67 65 74 2d 6b 65 79 2d 76 61 6c 73 0a get-key-vals.
8f90: 20 20 20 20 74 65 73 74 2d 74 6f 70 6c 65 76 65 test-topleve
8fa0: 6c 2d 6e 75 6d 2d 69 74 65 6d 73 0a 20 20 20 20 l-num-items.
8fb0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
8fc0: 2d 69 64 0a 20 20 20 20 67 65 74 2d 73 74 65 70 -id. get-step
8fd0: 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 0a 20 20 20 s-info-by-id.
8fe0: 20 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d 62 get-data-info-b
8ff0: 79 2d 69 64 0a 20 20 20 20 74 65 73 74 2d 67 65 y-id. test-ge
9000: 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 t-rundir-from-te
9010: 73 74 2d 69 64 0a 20 20 20 20 67 65 74 2d 63 6f st-id. get-co
9020: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
9030: 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d 65 0a 20 g-for-testname.
9040: 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 get-count-tes
9050: 74 73 2d 72 75 6e 6e 69 6e 67 0a 20 20 20 20 67 ts-running. g
9060: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
9070: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
9080: 75 70 0a 20 20 20 20 67 65 74 2d 70 72 65 76 69 up. get-previ
9090: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
90a0: 6f 72 64 0a 20 20 20 20 67 65 74 2d 6d 61 74 63 ord. get-matc
90b0: 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 hing-previous-te
90c0: 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 0a 20 st-run-records.
90d0: 20 20 20 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 test-get-logf
90e0: 69 6c 65 2d 69 6e 66 6f 0a 20 20 20 20 74 65 73 ile-info. tes
90f0: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
9100: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 0a 20 20 20 r-index-file.
9110: 20 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 get-testinfo-st
9120: 61 74 65 2d 73 74 61 74 75 73 0a 20 20 20 20 74 ate-status. t
9130: 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 est-get-top-proc
9140: 65 73 73 2d 70 69 64 0a 20 20 20 20 74 65 73 74 ess-pid. test
9150: 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 -get-paths-match
9160: 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 ing-keynames-tar
9170: 67 65 74 2d 6e 65 77 0a 20 20 20 20 67 65 74 2d get-new. get-
9180: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 0a prereqs-not-met.
9190: 20 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 get-count-te
91a0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
91b0: 72 75 6e 2d 69 64 0a 20 20 20 20 67 65 74 2d 72 run-id. get-r
91c0: 75 6e 2d 69 6e 66 6f 0a 20 20 20 20 67 65 74 2d un-info. get-
91d0: 72 75 6e 2d 73 74 61 74 75 73 0a 20 20 20 20 67 run-status. g
91e0: 65 74 2d 72 75 6e 2d 73 74 61 74 65 0a 20 20 20 et-run-state.
91f0: 20 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 0a 20 get-run-stats.
9200: 20 20 20 67 65 74 2d 72 75 6e 2d 74 69 6d 65 73 get-run-times
9210: 0a 20 20 20 20 67 65 74 2d 74 61 72 67 65 74 73 . get-targets
9220: 0a 20 20 20 20 67 65 74 2d 74 61 72 67 65 74 0a . get-target.
9230: 20 20 20 20 3b 3b 20 72 65 67 69 73 74 65 72 2d ;; register-
9240: 72 75 6e 0a 20 20 20 20 67 65 74 2d 74 65 73 74 run. get-test
9250: 73 2d 74 61 67 73 0a 20 20 20 20 67 65 74 2d 74 s-tags. get-t
9260: 65 73 74 2d 74 69 6d 65 73 0a 20 20 20 20 67 65 est-times. ge
9270: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a t-tests-for-run.
9280: 20 20 20 20 67 65 74 2d 74 65 73 74 2d 69 64 0a get-test-id.
9290: 20 20 20 20 67 65 74 2d 74 65 73 74 73 2d 66 6f get-tests-fo
92a0: 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 61 0a 20 r-runs-mindata.
92b0: 20 20 20 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 get-tests-for
92c0: 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 0a 20 20 20 -run-mindata.
92d0: 20 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 get-run-name-fr
92e0: 6f 6d 2d 69 64 0a 20 20 20 20 67 65 74 2d 72 75 om-id. get-ru
92f0: 6e 73 0a 20 20 20 20 73 69 6d 70 6c 65 2d 67 65 ns. simple-ge
9300: 74 2d 72 75 6e 73 0a 20 20 20 20 67 65 74 2d 6e t-runs. get-n
9310: 75 6d 2d 72 75 6e 73 0a 20 20 20 20 67 65 74 2d um-runs. get-
9320: 72 75 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 runs-cnt-by-patt
9330: 0a 20 20 20 20 67 65 74 2d 61 6c 6c 2d 72 75 6e . get-all-run
9340: 2d 69 64 73 0a 20 20 20 20 67 65 74 2d 70 72 65 -ids. get-pre
9350: 76 2d 72 75 6e 2d 69 64 73 0a 20 20 20 20 67 65 v-run-ids. ge
9360: 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 t-run-ids-matchi
9370: 6e 67 2d 74 61 72 67 65 74 0a 20 20 20 20 67 65 ng-target. ge
9380: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 0a 20 t-runs-by-patt.
9390: 20 20 20 67 65 74 2d 73 74 65 70 73 2d 64 61 74 get-steps-dat
93a0: 61 0a 20 20 20 20 67 65 74 2d 73 74 65 70 73 2d a. get-steps-
93b0: 66 6f 72 2d 74 65 73 74 0a 20 20 20 20 72 65 61 for-test. rea
93c0: 64 2d 74 65 73 74 2d 64 61 74 61 0a 20 20 20 20 d-test-data.
93d0: 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 2a 0a read-test-data*.
93e0: 20 20 20 20 6c 6f 67 69 6e 0a 20 20 20 20 74 61 login. ta
93f0: 73 6b 73 2d 67 65 74 2d 6c 61 73 74 0a 20 20 20 sks-get-last.
9400: 20 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 testmeta-get-re
9410: 63 6f 72 64 0a 20 20 20 20 68 61 76 65 2d 69 6e cord. have-in
9420: 63 6f 6d 70 6c 65 74 65 73 3f 0a 20 20 20 20 73 completes?. s
9430: 79 6e 63 68 61 73 68 2d 67 65 74 0a 20 20 20 20 ynchash-get.
9440: 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f get-changed-reco
9450: 72 64 2d 69 64 73 0a 09 09 67 65 74 2d 72 75 6e rd-ids...get-run
9460: 2d 72 65 63 6f 72 64 2d 69 64 73 20 0a 20 20 20 -record-ids .
9470: 20 67 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 get-not-complet
9480: 65 64 2d 63 6e 74 29 29 0a 0a 28 64 65 66 69 6e ed-cnt))..(defin
9490: 65 20 61 70 69 3a 77 72 69 74 65 2d 71 75 65 72 e api:write-quer
94a0: 69 65 73 0a 20 20 27 28 0a 20 20 20 20 67 65 74 ies. '(. get
94b0: 2d 6b 65 79 73 2d 77 72 69 74 65 20 3b 3b 20 64 -keys-write ;; d
94c0: 75 6d 6d 79 20 22 77 72 69 74 65 22 20 71 75 65 ummy "write" que
94d0: 72 79 20 74 6f 20 66 6f 72 63 65 20 73 65 72 76 ry to force serv
94e0: 65 72 20 73 74 61 72 74 0a 0a 20 20 20 20 3b 3b er start.. ;;
94f0: 20 53 45 52 56 45 52 53 0a 20 20 20 20 73 74 61 SERVERS. sta
9500: 72 74 2d 73 65 72 76 65 72 0a 20 20 20 20 6b 69 rt-server. ki
9510: 6c 6c 2d 73 65 72 76 65 72 0a 0a 20 20 20 20 3b ll-server.. ;
9520: 3b 20 54 45 53 54 53 0a 20 20 20 20 74 65 73 74 ; TESTS. test
9530: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
9540: 73 2d 62 79 2d 69 64 0a 20 20 20 20 64 65 6c 65 s-by-id. dele
9550: 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 0a te-test-records.
9560: 20 20 20 20 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 delete-old-d
9570: 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f eleted-test-reco
9580: 72 64 73 0a 20 20 20 20 74 65 73 74 2d 73 65 74 rds. test-set
9590: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 20 20 -state-status.
95a0: 20 20 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 test-set-top-p
95b0: 72 6f 63 65 73 73 2d 70 69 64 0a 20 20 20 20 73 rocess-pid. s
95c0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
95d0: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
95e0: 73 0a 20 20 20 20 20 0a 20 20 20 20 75 70 64 61 s. . upda
95f0: 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 te-pass-fail-cou
9600: 6e 74 73 0a 20 20 20 20 74 6f 70 2d 74 65 73 74 nts. top-test
9610: 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 6e -set-per-pf-coun
9620: 74 73 20 3b 3b 20 28 64 62 3a 74 6f 70 2d 74 65 ts ;; (db:top-te
9630: 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f st-set-per-pf-co
9640: 75 6e 74 73 20 28 64 62 3a 67 65 74 2d 64 62 20 unts (db:get-db
9650: 2a 64 62 2a 20 35 29 20 35 20 22 72 75 6e 66 69 *db* 5) 5 "runfi
9660: 72 73 74 22 29 0a 0a 20 20 20 20 3b 3b 20 52 55 rst").. ;; RU
9670: 4e 53 0a 20 20 20 20 72 65 67 69 73 74 65 72 2d NS. register-
9680: 72 75 6e 0a 20 20 20 20 73 65 74 2d 74 65 73 74 run. set-test
9690: 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 20 s-state-status.
96a0: 20 20 20 64 65 6c 65 74 65 2d 72 75 6e 0a 20 20 delete-run.
96b0: 20 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 lock/unlock-ru
96c0: 6e 0a 20 20 20 20 75 70 64 61 74 65 2d 72 75 6e n. update-run
96d0: 2d 65 76 65 6e 74 5f 74 69 6d 65 0a 20 20 20 20 -event_time.
96e0: 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 0a mark-incomplete.
96f0: 20 20 20 20 73 65 74 2d 73 74 61 74 65 2d 73 74 set-state-st
9700: 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 atus-and-roll-up
9710: 2d 72 75 6e 0a 20 20 20 20 3b 3b 20 53 54 45 50 -run. ;; STEP
9720: 53 0a 20 20 20 20 74 65 73 74 73 74 65 70 2d 73 S. teststep-s
9730: 65 74 2d 73 74 61 74 75 73 21 0a 20 20 20 20 64 et-status!. d
9740: 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 6f 72 2d elete-steps-for-
9750: 74 65 73 74 0a 20 20 20 20 3b 3b 20 54 45 53 54 test. ;; TEST
9760: 20 44 41 54 41 0a 20 20 20 20 74 65 73 74 2d 64 DATA. test-d
9770: 61 74 61 2d 72 6f 6c 6c 75 70 0a 20 20 20 20 63 ata-rollup. c
9780: 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 0a 0a 20 sv->test-data..
9790: 20 20 20 3b 3b 20 4d 49 53 43 0a 20 20 20 20 73 ;; MISC. s
97a0: 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 0a 0a 20 ync-inmem->db..
97b0: 20 20 20 3b 3b 20 54 45 53 54 4d 45 54 41 0a 20 ;; TESTMETA.
97c0: 20 20 20 74 65 73 74 6d 65 74 61 2d 61 64 64 2d testmeta-add-
97d0: 72 65 63 6f 72 64 0a 20 20 20 20 74 65 73 74 6d record. testm
97e0: 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 eta-update-field
97f0: 0a 0a 20 20 20 20 3b 3b 20 54 41 53 4b 53 0a 20 .. ;; TASKS.
9800: 20 20 20 74 61 73 6b 73 2d 61 64 64 0a 20 20 20 tasks-add.
9810: 20 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 tasks-set-state
9820: 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 -given-param-key
9830: 0a 20 20 20 20 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d . ))..;;=====
9840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9880: 3d 0a 3b 3b 20 41 4c 4c 44 41 54 41 0a 3b 3b 3d =.;; ALLDATA.;;=
9890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98d0: 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 20 61 74 74 65 =====.;;.;; atte
98e0: 6d 70 74 20 74 6f 20 63 6f 6e 73 6f 6c 69 64 61 mpt to consolida
98f0: 74 65 20 61 20 62 75 6e 63 68 20 6f 66 20 67 6c te a bunch of gl
9900: 6f 62 61 6c 20 69 6e 66 6f 72 6d 61 74 69 6f 6e obal information
9910: 20 69 6e 74 6f 20 6f 6e 65 20 73 74 72 75 63 74 into one struct
9920: 20 74 6f 20 74 6f 73 73 20 61 72 6f 75 6e 64 0a to toss around.
9930: 28 64 65 66 73 74 72 75 63 74 20 61 6c 6c 64 61 (defstruct allda
9940: 74 0a 20 20 3b 3b 20 6d 69 73 63 0a 20 20 28 64 t. ;; misc. (d
9950: 65 6e 6f 69 73 65 20 20 20 20 20 20 20 20 20 20 enoise
9960: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
9970: 65 29 29 0a 20 20 28 61 72 65 61 70 61 74 68 20 e)). (areapath
9980: 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 #f) ;;
9990: 69 2e 65 2e 20 74 6f 70 70 61 74 68 0a 20 20 28 i.e. toppath. (
99a0: 6d 74 63 6f 6e 66 69 67 20 20 20 20 20 20 20 20 mtconfig
99b0: 20 20 23 66 29 0a 20 20 28 6c 6f 67 2d 70 6f 72 #f). (log-por
99c0: 74 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 t #f).
99d0: 20 28 61 72 65 61 64 61 74 20 20 20 20 20 20 20 (areadat
99e0: 20 20 20 20 23 66 29 20 3b 3b 20 69 2e 65 2e 20 #f) ;; i.e.
99f0: 72 75 6e 72 65 6d 6f 74 65 0a 20 20 28 72 6d 74 runremote. (rmt
9a00: 2d 6d 75 74 65 78 20 20 20 20 20 20 20 20 20 28 -mutex (
9a10: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 20 20 28 make-mutex)). (
9a20: 64 62 2d 73 79 6e 63 2d 6d 75 74 65 78 20 20 20 db-sync-mutex
9a30: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
9a40: 20 20 28 64 62 2d 77 69 74 68 2d 64 62 2d 6d 75 (db-with-db-mu
9a50: 74 65 78 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 tex (make-mutex
9a60: 29 29 0a 20 20 28 72 65 61 64 2d 6f 6e 6c 79 2d )). (read-only-
9a70: 71 75 65 72 69 65 73 20 61 70 69 3a 72 65 61 64 queries api:read
9a80: 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 0a 20 -only-queries).
9a90: 20 28 77 72 69 74 65 2d 71 75 65 72 69 65 73 20 (write-queries
9aa0: 20 20 20 20 61 70 69 3a 77 72 69 74 65 2d 71 75 api:write-qu
9ab0: 65 72 69 65 73 29 0a 20 20 28 6d 61 78 2d 61 70 eries). (max-ap
9ac0: 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 i-process-reques
9ad0: 74 73 20 30 29 0a 20 20 28 61 70 69 2d 70 72 6f ts 0). (api-pro
9ae0: 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 cess-request-cou
9af0: 6e 74 20 30 29 0a 20 20 28 64 62 2d 6b 65 79 73 nt 0). (db-keys
9b00: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 #f).
9b10: 20 28 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 (megatest-versi
9b20: 6f 6e 20 20 22 31 2e 36 35 33 36 22 29 0a 20 20 on "1.6536").
9b30: 28 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c (megatest-fossil
9b40: 2d 68 61 73 68 20 23 66 29 0a 20 20 0a 20 20 3b -hash #f). . ;
9b50: 3b 20 64 61 74 61 62 61 73 65 20 72 65 6c 61 74 ; database relat
9b60: 65 64 0a 20 20 28 74 6d 70 70 61 74 68 20 20 20 ed. (tmppath
9b70: 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 74 #f) ;; t
9b80: 6d 70 20 70 61 74 68 20 66 6f 72 20 64 62 73 0a mp path for dbs.
9b90: 0a 20 20 3b 3b 20 72 75 6e 72 65 6d 6f 74 65 20 . ;; runremote
9ba0: 66 69 65 6c 64 73 0a 20 20 28 68 68 2d 64 61 74 fields. (hh-dat
9bb0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 #f)
9bc0: 3b 3b 20 28 65 78 65 63 2d 66 6e 20 27 63 6f 6d ;; (exec-fn 'com
9bd0: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
9be0: 29 29 20 3b 3b 20 68 6f 6d 65 68 6f 73 74 20 72 )) ;; homehost r
9bf0: 65 63 6f 72 64 20 28 20 61 64 64 72 20 2e 20 68 ecord ( addr . h
9c00: 68 66 6c 61 67 20 29 0a 20 20 28 73 65 72 76 65 hflag ). (serve
9c10: 72 2d 75 72 6c 20 20 20 20 20 20 20 20 23 66 29 r-url #f)
9c20: 20 3b 3b 20 28 69 66 20 2a 74 6f 70 70 61 74 68 ;; (if *toppath
9c30: 2a 20 28 65 78 65 63 2d 66 6e 20 27 73 65 72 76 * (exec-fn 'serv
9c40: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
9c50: 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 ing *toppath*)))
9c60: 20 3b 3b 20 28 73 65 72 76 65 72 3a 63 68 65 63 ;; (server:chec
9c70: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
9c80: 70 70 61 74 68 2a 29 20 23 66 29 29 0a 20 20 28 ppath*) #f)). (
9c90: 6c 61 73 74 2d 73 65 72 76 65 72 2d 63 68 65 63 last-server-chec
9ca0: 6b 20 30 29 20 20 3b 3b 20 6c 61 73 74 20 74 69 k 0) ;; last ti
9cb0: 6d 65 20 77 65 20 63 68 65 63 6b 65 64 20 74 6f me we checked to
9cc0: 20 73 65 65 20 69 66 20 74 68 65 20 73 65 72 76 see if the serv
9cd0: 65 72 20 77 61 73 20 61 6c 69 76 65 0a 20 20 28 er was alive. (
9ce0: 63 6f 6e 6e 64 61 74 20 20 20 20 20 20 20 20 20 conndat
9cf0: 20 20 23 66 29 0a 20 20 28 74 72 61 6e 73 70 6f #f). (transpo
9d00: 72 74 20 20 20 20 20 20 20 20 20 2a 74 72 61 6e rt *tran
9d10: 73 70 6f 72 74 2d 74 79 70 65 2a 29 0a 20 20 28 sport-type*). (
9d20: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 20 server-timeout
9d30: 20 20 23 66 29 20 3b 3b 20 28 65 78 65 63 2d 66 #f) ;; (exec-f
9d40: 6e 20 27 73 65 72 76 65 72 3a 65 78 70 69 72 61 n 'server:expira
9d50: 74 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 29 0a 20 tion-timeout)).
9d60: 20 28 66 6f 72 63 65 2d 73 65 72 76 65 72 20 20 (force-server
9d70: 20 20 20 20 23 66 29 0a 20 20 28 72 6f 2d 6d 6f #f). (ro-mo
9d80: 64 65 20 20 20 20 20 20 20 20 20 20 20 23 66 29 de #f)
9d90: 20 20 0a 20 20 28 72 6f 2d 6d 6f 64 65 2d 63 68 . (ro-mode-ch
9da0: 65 63 6b 65 64 20 20 20 23 66 29 20 3b 3b 20 66 ecked #f) ;; f
9db0: 6c 61 67 20 74 68 61 74 20 69 6e 64 69 63 61 74 lag that indicat
9dc0: 65 73 20 77 65 20 68 61 76 65 20 63 68 65 63 6b es we have check
9dd0: 65 64 20 66 6f 72 20 72 6f 2d 6d 6f 64 65 0a 20 ed for ro-mode.
9de0: 20 28 75 6c 65 78 3a 63 6f 6e 6e 20 20 20 20 20 (ulex:conn
9df0: 20 20 20 20 23 66 29 20 3b 3b 20 75 6c 65 78 20 #f) ;; ulex
9e00: 64 62 20 63 6f 6e 6e 20 69 73 20 6e 6f 74 20 65 db conn is not e
9e10: 78 61 63 74 6c 79 20 61 20 64 62 20 63 6f 6e 6e xactly a db conn
9e20: 65 63 74 6f 72 2c 20 6d 6f 72 65 20 6c 69 6b 65 ector, more like
9e30: 20 61 20 6e 65 74 77 6f 72 6b 20 63 6f 6e 6e 65 a network conne
9e40: 63 74 6f 72 20 0a 0a 20 20 3b 3b 20 64 62 73 74 ctor .. ;; dbst
9e50: 72 75 63 74 0a 20 20 28 74 6d 70 64 62 20 20 20 ruct. (tmpdb
9e60: 20 20 20 20 23 66 29 0a 20 20 28 64 62 73 74 61 #f). (dbsta
9e70: 63 6b 20 20 20 20 20 23 66 29 20 3b 3b 20 73 74 ck #f) ;; st
9e80: 61 63 6b 20 66 6f 72 20 74 6d 70 20 64 62 20 68 ack for tmp db h
9e90: 61 6e 64 6c 65 73 2c 20 64 6f 20 6e 6f 74 20 69 andles, do not i
9ea0: 6e 69 74 69 61 6c 69 7a 65 20 77 69 74 68 20 61 nitialize with a
9eb0: 20 73 74 61 63 6b 0a 20 20 28 6d 74 64 62 20 20 stack. (mtdb
9ec0: 20 20 20 20 20 20 23 66 29 0a 20 20 28 72 65 66 #f). (ref
9ed0: 6e 64 62 20 20 20 20 20 20 23 66 29 0a 20 20 28 ndb #f). (
9ee0: 68 6f 6d 65 68 6f 73 74 20 20 20 20 23 66 29 20 homehost #f)
9ef0: 3b 3b 20 6e 6f 74 20 75 73 65 64 20 79 65 74 0a ;; not used yet.
9f00: 20 20 28 6f 6e 2d 68 6f 6d 65 68 6f 73 74 20 23 (on-homehost #
9f10: 66 29 20 3b 3b 20 6e 6f 74 20 75 73 65 64 20 79 f) ;; not used y
9f20: 65 74 0a 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 et. (read-only
9f30: 20 20 23 66 29 0a 0a 20 20 29 0a 0a 28 64 65 66 #f).. )..(def
9f40: 69 6e 65 20 2a 61 6c 6c 64 61 74 2a 20 28 6d 61 ine *alldat* (ma
9f50: 6b 65 2d 61 6c 6c 64 61 74 29 29 0a 0a 3b 3b 20 ke-alldat))..;;
9f60: 53 6f 6d 65 20 6f 66 20 74 68 65 73 65 20 72 6f Some of these ro
9f70: 75 74 69 6e 65 73 20 75 73 65 3a 0a 3b 3b 0a 3b utines use:.;;.;
9f80: 3b 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 77 ; http://www
9f90: 2e 63 73 2e 74 6f 72 6f 6e 74 6f 2e 65 64 75 2f .cs.toronto.edu/
9fa0: 7e 67 66 62 2f 73 63 68 65 6d 65 2f 73 69 6d 70 ~gfb/scheme/simp
9fb0: 6c 65 2d 6d 61 63 72 6f 73 2e 68 74 6d 6c 0a 3b le-macros.html.;
9fc0: 3b 0a 3b 3b 20 53 79 6e 74 61 78 20 66 6f 72 20 ;.;; Syntax for
9fd0: 64 65 66 69 6e 69 6e 67 20 6d 61 63 72 6f 73 20 defining macros
9fe0: 69 6e 20 61 20 73 69 6d 70 6c 65 20 73 74 79 6c in a simple styl
9ff0: 65 20 73 69 6d 69 6c 61 72 20 74 6f 20 66 75 6e e similar to fun
a000: 63 74 69 6f 6e 20 64 65 66 69 6e 69 74 6f 6e 2c ction definiton,
a010: 0a 3b 3b 20 20 77 68 65 6e 20 74 68 65 72 65 20 .;; when there
a020: 69 73 20 61 20 73 69 6e 67 6c 65 20 70 61 74 74 is a single patt
a030: 65 72 6e 20 66 6f 72 20 74 68 65 20 61 72 67 75 ern for the argu
a040: 6d 65 6e 74 20 6c 69 73 74 20 61 6e 64 20 74 68 ment list and th
a050: 65 72 65 20 61 72 65 20 6e 6f 20 6b 65 79 77 6f ere are no keywo
a060: 72 64 73 2e 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 rds..;;.;; (defi
a070: 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 ne-simple-syntax
a080: 20 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 (name arg ...)
a090: 62 6f 64 79 20 2e 2e 2e 29 0a 3b 3b 0a 0a 28 64 body ...).;;..(d
a0a0: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 efine-syntax def
a0b0: 69 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 ine-simple-synta
a0c0: 78 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 x. (syntax-rule
a0d0: 73 20 28 29 0a 20 20 20 20 28 28 5f 20 28 6e 61 s (). ((_ (na
a0e0: 6d 65 20 61 72 67 20 2e 2e 2e 29 20 62 6f 64 79 me arg ...) body
a0f0: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 64 65 66 69 ...). (defi
a100: 6e 65 2d 73 79 6e 74 61 78 20 6e 61 6d 65 20 28 ne-syntax name (
a110: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 20 syntax-rules ()
a120: 28 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e 29 20 ((name arg ...)
a130: 28 62 65 67 69 6e 20 62 6f 64 79 20 2e 2e 2e 29 (begin body ...)
a140: 29 29 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 ))))))..;; (defi
a150: 6e 65 2d 73 79 6e 74 61 78 20 63 6f 6d 6d 6f 6e ne-syntax common
a160: 3a 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f :handle-exceptio
a170: 6e 73 0a 3b 3b 20 20 20 28 73 79 6e 74 61 78 2d ns.;; (syntax-
a180: 72 75 6c 65 73 20 28 29 0a 3b 3b 20 20 20 20 20 rules ().;;
a190: 28 28 5f 20 65 78 6e 2d 69 6e 20 65 72 72 73 74 ((_ exn-in errst
a1a0: 6d 74 20 2e 2e 2e 29 28 68 61 6e 64 6c 65 2d 65 mt ...)(handle-e
a1b0: 78 63 65 70 74 69 6f 6e 73 20 65 78 6e 2d 69 6e xceptions exn-in
a1c0: 20 65 72 72 73 74 6d 74 20 2e 2e 2e 29 29 29 29 errstmt ...))))
a1d0: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
a1e0: 20 63 6f 6d 6d 6f 6e 3a 64 65 62 75 67 2d 68 61 common:debug-ha
a1f0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
a200: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
a210: 28 29 0a 20 20 20 20 28 28 5f 20 64 65 62 75 67 (). ((_ debug
a220: 20 65 78 6e 20 65 72 72 73 74 6d 74 20 62 6f 64 exn errstmt bod
a230: 79 20 2e 2e 2e 29 0a 20 20 20 20 20 28 69 66 20 y ...). (if
a240: 64 65 62 75 67 0a 09 20 28 62 65 67 69 6e 20 62 debug.. (begin b
a250: 6f 64 79 20 2e 2e 2e 29 0a 09 20 28 68 61 6e 64 ody ...).. (hand
a260: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 65 78 le-exceptions ex
a270: 6e 20 65 72 72 73 74 6d 74 20 62 6f 64 79 20 2e n errstmt body .
a280: 2e 2e 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..)))))..(define
a290: 2d 73 79 6e 74 61 78 20 63 6f 6d 6d 6f 6e 3a 68 -syntax common:h
a2a0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
a2b0: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
a2c0: 20 28 29 0a 20 20 20 20 28 28 5f 20 65 78 6e 20 (). ((_ exn
a2d0: 65 72 72 73 74 6d 74 20 62 6f 64 79 20 2e 2e 2e errstmt body ...
a2e0: 29 0a 20 20 20 20 20 28 62 65 67 69 6e 20 62 6f ). (begin bo
a2f0: 64 79 20 2e 2e 2e 29 29 29 29 0a 0a 3b 3b 20 28 dy ...))))..;; (
a300: 64 65 66 69 6e 65 20 68 61 6e 64 6c 65 2d 65 78 define handle-ex
a310: 63 65 70 74 69 6f 6e 73 20 63 6f 6d 6d 6f 6e 3a ceptions common:
a320: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
a330: 73 29 0a 0a 3b 3b 20 69 75 70 20 63 61 6c 6c 62 s)..;; iup callb
a340: 61 63 6b 73 20 61 72 65 20 6e 6f 74 20 64 75 6d acks are not dum
a350: 70 69 6e 67 20 74 68 65 20 73 74 61 63 6b 2c 20 ping the stack,
a360: 74 68 69 73 20 69 73 20 61 20 77 6f 72 6b 2d 61 this is a work-a
a370: 72 6f 75 6e 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 round.;;.(define
a380: 2d 73 69 6d 70 6c 65 2d 73 79 6e 74 61 78 20 28 -simple-syntax (
a390: 64 65 62 75 67 3a 63 61 74 63 68 2d 61 6e 64 2d debug:catch-and-
a3a0: 64 75 6d 70 20 70 72 6f 63 20 70 72 6f 63 6e 61 dump proc procna
a3b0: 6d 65 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 me). (handle-ex
a3c0: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
a3d0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 (begin. (
a3e0: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
a3f0: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
a400: 70 6f 72 74 29 29 0a 20 20 20 20 20 28 77 69 74 port)). (wit
a410: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
a420: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
a430: 70 6f 72 74 29 0a 20 20 20 20 20 20 20 28 6c 61 port). (la
a440: 6d 62 64 61 20 28 29 0a 09 20 28 70 72 69 6e 74 mbda ().. (print
a450: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
a460: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
a470: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
a480: 6e 29 29 0a 09 20 28 70 72 69 6e 74 20 22 43 61 n)).. (print "Ca
a490: 6c 6c 62 61 63 6b 20 65 72 72 6f 72 20 69 6e 20 llback error in
a4a0: 22 20 70 72 6f 63 6e 61 6d 65 29 0a 09 20 28 70 " procname).. (p
a4b0: 72 69 6e 74 20 22 46 75 6c 6c 20 63 6f 6e 64 69 rint "Full condi
a4c0: 74 69 6f 6e 20 69 6e 66 6f 3a 5c 6e 22 20 28 63 tion info:\n" (c
a4d0: 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 ondition->list e
a4e0: 78 6e 29 29 29 29 29 0a 20 20 20 28 70 72 6f 63 xn))))). (proc
a4f0: 29 29 29 0a 0a 3b 3b 20 4e 65 65 64 20 61 20 6d )))..;; Need a m
a500: 75 74 65 78 20 70 72 6f 74 65 63 74 65 64 20 77 utex protected w
a510: 61 79 20 74 6f 20 67 65 74 20 61 6e 64 20 73 65 ay to get and se
a520: 74 20 76 61 6c 75 65 73 0a 3b 3b 20 6f 72 20 75 t values.;; or u
a530: 73 65 20 28 64 65 66 69 6e 65 2d 73 69 6d 70 6c se (define-simpl
a540: 65 2d 73 79 6e 74 61 78 20 3f 3f 0a 3b 3b 0a 28 e-syntax ??.;;.(
a550: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 77 define-inline (w
a560: 69 74 68 2d 6d 75 74 65 78 20 6d 74 78 20 61 63 ith-mutex mtx ac
a570: 63 65 73 73 6f 72 20 72 65 63 6f 72 64 20 2e 20 cessor record .
a580: 76 61 6c 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f val). (mutex-lo
a590: 63 6b 21 20 6d 74 78 29 0a 20 20 28 6c 65 74 20 ck! mtx). (let
a5a0: 28 28 72 65 73 20 28 61 70 70 6c 79 20 61 63 63 ((res (apply acc
a5b0: 65 73 73 6f 72 20 72 65 63 6f 72 64 20 76 61 6c essor record val
a5c0: 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 ))). (mutex-u
a5d0: 6e 6c 6f 63 6b 21 20 6d 74 78 29 0a 20 20 20 20 nlock! mtx).
a5e0: 72 65 73 29 29 0a 0a 3b 3b 20 42 72 61 6e 64 6f res))..;; Brando
a5f0: 6e 27 73 20 64 65 62 75 67 20 70 72 69 6e 74 65 n's debug printe
a600: 72 20 73 68 6f 72 74 63 75 74 20 28 69 6e 64 75 r shortcut (indu
a610: 6c 67 65 20 6d 65 20 3a 29 0a 3b 3b 20 28 64 65 lge me :).;; (de
a620: 66 69 6e 65 20 2a 42 42 2d 70 72 6f 63 65 73 73 fine *BB-process
a630: 2d 73 74 61 72 74 74 69 6d 65 2a 20 28 63 75 72 -starttime* (cur
a640: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
a650: 73 29 29 0a 23 3b 28 64 65 66 69 6e 65 20 28 42 s)).#;(define (B
a660: 42 3e 20 2e 20 69 6e 2d 61 72 67 73 29 0a 20 20 B> . in-args).
a670: 28 6c 65 74 2a 20 28 28 73 74 61 63 6b 20 28 67 (let* ((stack (g
a680: 65 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 0a et-call-chain)).
a690: 20 20 20 20 20 20 20 20 20 28 6c 6f 63 61 74 69 (locati
a6a0: 6f 6e 20 22 3f 3f 22 29 29 0a 20 20 20 20 28 66 on "??")). (f
a6b0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
a6c0: 6d 62 64 61 20 28 66 72 61 6d 65 29 0a 20 20 20 mbda (frame).
a6d0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 69 73 (let* ((this
a6e0: 2d 6c 6f 63 20 28 76 65 63 74 6f 72 2d 72 65 66 -loc (vector-ref
a6f0: 20 66 72 61 6d 65 20 30 29 29 0a 20 20 20 20 20 frame 0)).
a700: 20 20 20 20 20 20 20 20 20 28 74 65 6d 70 20 20 (temp
a710: 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
a720: 20 28 2d 3e 73 74 72 69 6e 67 20 74 68 69 73 2d (->string this-
a730: 6c 6f 63 29 20 22 20 22 29 29 0a 20 20 20 20 20 loc) " ")).
a740: 20 20 20 20 20 20 20 20 20 28 74 68 69 73 2d 66 (this-f
a750: 75 6e 63 20 28 69 66 20 28 61 6e 64 20 28 6c 69 unc (if (and (li
a760: 73 74 3f 20 74 65 6d 70 29 20 28 3e 20 28 6c 65 st? temp) (> (le
a770: 6e 67 74 68 20 74 65 6d 70 29 20 31 29 29 20 28 ngth temp) 1)) (
a780: 63 61 64 72 20 74 65 6d 70 29 20 22 3f 3f 3f 22 cadr temp) "???"
a790: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 ))). (if
a7a0: 20 28 65 71 75 61 6c 3f 20 74 68 69 73 2d 66 75 (equal? this-fu
a7b0: 6e 63 20 22 42 42 3e 22 29 0a 20 20 20 20 20 20 nc "BB>").
a7c0: 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 6f 63 (set! loc
a7d0: 61 74 69 6f 6e 20 74 68 69 73 2d 6c 6f 63 29 29 ation this-loc))
a7e0: 29 29 0a 20 20 20 20 20 73 74 61 63 6b 29 0a 20 )). stack).
a7f0: 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6c 6f 72 (let* ((color
a800: 2d 6f 6e 20 22 5c 78 31 62 5b 31 6d 22 29 0a 20 -on "\x1b[1m").
a810: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6c 6f 72 (color
a820: 2d 6f 66 66 20 22 5c 78 31 62 5b 30 6d 22 29 0a -off "\x1b[0m").
a830: 20 20 20 20 20 20 20 20 20 20 20 28 64 70 2d 61 (dp-a
a840: 72 67 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 rgs.
a850: 28 61 70 70 65 6e 64 0a 20 20 20 20 20 20 20 20 (append.
a860: 20 20 20 20 20 28 6c 69 73 74 20 30 20 2a 64 65 (list 0 *de
a870: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a fault-log-port*.
a880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a890: 20 20 20 28 63 6f 6e 63 20 63 6f 6c 6f 72 2d 6f (conc color-o
a8a0: 6e 20 6c 6f 63 61 74 69 6f 6e 20 22 40 22 28 2f n location "@"(/
a8b0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (- (current-mil
a8c0: 6c 69 73 65 63 6f 6e 64 73 29 20 2a 42 42 2d 70 liseconds) *BB-p
a8d0: 72 6f 63 65 73 73 2d 73 74 61 72 74 74 69 6d 65 rocess-starttime
a8e0: 2a 29 20 31 30 30 30 29 20 63 6f 6c 6f 72 2d 6f *) 1000) color-o
a8f0: 66 66 20 22 20 20 20 22 29 20 20 29 0a 20 20 20 ff " ") ).
a900: 20 20 20 20 20 20 20 20 20 20 69 6e 2d 61 72 67 in-arg
a910: 73 29 29 29 0a 20 20 20 20 20 20 28 61 70 70 6c s))). (appl
a920: 79 20 64 65 62 75 67 3a 70 72 69 6e 74 20 64 70 y debug:print dp
a930: 2d 61 72 67 73 29 29 29 29 0a 0a 3b 3b 20 28 64 -args))))..;; (d
a940: 65 66 69 6e 65 20 2a 42 42 70 70 5f 63 75 73 74 efine *BBpp_cust
a950: 6f 6d 5f 65 78 70 61 6e 64 65 72 73 5f 6c 69 73 om_expanders_lis
a960: 74 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 t* (make-hash-ta
a970: 62 6c 65 29 29 0a 0a 0a 0a 3b 3b 20 72 65 67 69 ble))....;; regi
a980: 73 74 65 72 20 68 61 73 68 20 74 61 62 6c 65 73 ster hash tables
a990: 20 77 69 74 68 20 42 42 70 70 2e 0a 23 3b 28 68 with BBpp..#;(h
a9a0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
a9b0: 42 42 70 70 5f 63 75 73 74 6f 6d 5f 65 78 70 61 BBpp_custom_expa
a9c0: 6e 64 65 72 73 5f 6c 69 73 74 2a 20 48 41 53 48 nders_list* HASH
a9d0: 5f 54 41 42 4c 45 3a 0a 20 20 20 20 20 20 20 20 _TABLE:.
a9e0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 68 (cons h
a9f0: 61 73 68 2d 74 61 62 6c 65 3f 20 68 61 73 68 2d ash-table? hash-
aa00: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 29 29 0a 0a table->alist))..
aa10: 3b 3b 20 74 65 73 74 20 6e 61 6d 65 20 63 6f 6e ;; test name con
aa20: 76 65 72 74 65 72 0a 23 3b 28 64 65 66 69 6e 65 verter.#;(define
aa30: 20 28 42 42 70 70 5f 63 75 73 74 6f 6d 5f 63 6f (BBpp_custom_co
aa40: 6e 76 65 72 74 65 72 20 61 72 67 29 0a 20 20 28 nverter arg). (
aa50: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 let ((res #f)).
aa60: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
aa70: 20 20 28 6c 61 6d 62 64 61 20 28 63 75 73 74 6f (lambda (custo
aa80: 6d 2d 74 79 70 65 2d 6e 61 6d 65 29 0a 20 20 20 m-type-name).
aa90: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 73 74 (let* ((cust
aaa0: 6f 6d 2d 74 79 70 65 2d 69 6e 66 6f 20 20 20 20 om-type-info
aab0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
aac0: 66 20 2a 42 42 70 70 5f 63 75 73 74 6f 6d 5f 65 f *BBpp_custom_e
aad0: 78 70 61 6e 64 65 72 73 5f 6c 69 73 74 2a 20 63 xpanders_list* c
aae0: 75 73 74 6f 6d 2d 74 79 70 65 2d 6e 61 6d 65 29 ustom-type-name)
aaf0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ab00: 28 63 75 73 74 6f 6d 2d 74 79 70 65 2d 74 65 73 (custom-type-tes
ab10: 74 20 20 20 20 20 20 28 63 61 72 20 63 75 73 74 t (car cust
ab20: 6f 6d 2d 74 79 70 65 2d 69 6e 66 6f 29 29 0a 20 om-type-info)).
ab30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 (cu
ab40: 73 74 6f 6d 2d 74 79 70 65 2d 63 6f 6e 76 65 72 stom-type-conver
ab50: 74 65 72 20 28 63 64 72 20 63 75 73 74 6f 6d 2d ter (cdr custom-
ab60: 74 79 70 65 2d 69 6e 66 6f 29 29 29 0a 20 20 20 type-info))).
ab70: 20 20 20 20 20 20 28 77 68 65 6e 20 28 61 6e 64 (when (and
ab80: 20 28 6e 6f 74 20 72 65 73 29 20 28 63 75 73 74 (not res) (cust
ab90: 6f 6d 2d 74 79 70 65 2d 74 65 73 74 20 61 72 67 om-type-test arg
aba0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 )). (s
abb0: 65 74 21 20 72 65 73 20 28 63 75 73 74 6f 6d 2d et! res (custom-
abc0: 74 79 70 65 2d 63 6f 6e 76 65 72 74 65 72 20 61 type-converter a
abd0: 72 67 29 29 29 29 29 0a 20 20 20 20 20 28 68 61 rg))))). (ha
abe0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 42 sh-table-keys *B
abf0: 42 70 70 5f 63 75 73 74 6f 6d 5f 65 78 70 61 6e Bpp_custom_expan
ac00: 64 65 72 73 5f 6c 69 73 74 2a 29 29 0a 20 20 20 ders_list*)).
ac10: 20 28 69 66 20 72 65 73 20 28 42 42 70 70 5f 20 (if res (BBpp_
ac20: 72 65 73 29 20 61 72 67 29 29 29 0a 0a 23 3b 28 res) arg)))..#;(
ac30: 64 65 66 69 6e 65 20 28 42 42 70 70 5f 20 61 72 define (BBpp_ ar
ac40: 67 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 3b 3b g). (cond. ;;
ac50: 28 28 53 4f 4d 45 53 54 52 55 43 54 3f 20 61 72 ((SOMESTRUCT? ar
ac60: 67 29 20 28 63 6f 6e 73 20 53 4f 4d 45 53 54 52 g) (cons SOMESTR
ac70: 55 43 54 3a 20 28 53 4f 4d 45 53 54 52 55 43 54 UCT: (SOMESTRUCT
ac80: 2d 3e 61 6c 69 73 74 20 61 72 67 29 29 29 0a 20 ->alist arg))).
ac90: 20 20 3b 3b 28 28 64 62 6f 61 72 64 3a 74 61 62 ;;((dboard:tab
aca0: 64 61 74 3f 20 61 72 67 29 20 28 63 6f 6e 73 20 dat? arg) (cons
acb0: 64 62 6f 61 72 64 3a 74 61 62 64 61 74 3a 20 28 dboard:tabdat: (
acc0: 64 62 6f 61 72 64 3a 74 61 62 64 61 74 2d 3e 61 dboard:tabdat->a
acd0: 6c 69 73 74 20 61 72 67 29 29 29 0a 20 20 20 28 list arg))). (
ace0: 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 61 72 67 (hash-table? arg
acf0: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6c 20 ). (let ((al
ad00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
ad10: 73 74 20 61 72 67 29 29 29 0a 20 20 20 20 20 20 st arg))).
ad20: 28 42 42 70 70 5f 20 28 63 6f 6e 73 20 48 41 53 (BBpp_ (cons HAS
ad30: 48 5f 54 41 42 4c 45 3a 20 61 6c 29 29 29 29 0a H_TABLE: al)))).
ad40: 20 20 20 28 28 6e 75 6c 6c 3f 20 61 72 67 29 20 ((null? arg)
ad50: 27 28 29 29 0a 20 20 20 3b 3b 28 28 6c 69 73 74 '()). ;;((list
ad60: 3f 20 61 72 67 29 20 28 63 6f 6e 73 20 28 42 42 ? arg) (cons (BB
ad70: 70 70 5f 20 28 63 61 72 20 61 72 67 29 29 20 28 pp_ (car arg)) (
ad80: 42 42 70 70 5f 20 28 63 64 72 20 61 72 67 29 29 BBpp_ (cdr arg))
ad90: 29 29 0a 20 20 20 28 28 70 61 69 72 3f 20 61 72 )). ((pair? ar
ada0: 67 29 20 28 63 6f 6e 73 20 28 42 42 70 70 5f 20 g) (cons (BBpp_
adb0: 28 63 61 72 20 61 72 67 29 29 20 28 42 42 70 70 (car arg)) (BBpp
adc0: 5f 20 28 63 64 72 20 61 72 67 29 29 29 29 0a 20 _ (cdr arg)))).
add0: 20 20 28 65 6c 73 65 20 28 42 42 70 70 5f 63 75 (else (BBpp_cu
ade0: 73 74 6f 6d 5f 63 6f 6e 76 65 72 74 65 72 20 61 stom_converter a
adf0: 72 67 29 29 29 29 0a 0a 3b 3b 20 42 72 61 6e 64 rg))))..;; Brand
ae00: 6f 6e 27 73 20 70 72 65 74 74 79 20 70 72 69 6e on's pretty prin
ae10: 74 65 72 2e 20 20 49 74 20 65 78 70 61 6e 64 73 ter. It expands
ae20: 20 68 61 73 68 65 73 20 61 6e 64 20 63 75 73 74 hashes and cust
ae30: 6f 6d 20 74 79 70 65 73 20 69 6e 20 61 64 64 69 om types in addi
ae40: 74 69 6f 6e 20 74 6f 20 72 65 67 75 6c 61 72 20 tion to regular
ae50: 70 70 0a 23 3b 28 64 65 66 69 6e 65 20 28 42 42 pp.#;(define (BB
ae60: 70 70 20 61 72 67 29 0a 20 20 28 70 70 20 28 42 pp arg). (pp (B
ae70: 42 70 70 5f 20 61 72 67 29 29 29 0a 0a 3b 28 75 Bpp_ arg)))..;(u
ae80: 73 65 20 64 65 66 69 6e 65 2d 6d 61 63 72 6f 29 se define-macro)
ae90: 0a 23 3b 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 .#;(define-synta
aea0: 78 20 69 6e 73 70 65 63 74 0a 20 20 28 73 79 6e x inspect. (syn
aeb0: 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 tax-rules ().
aec0: 20 5b 28 5f 20 78 29 0a 20 20 20 20 3b 3b 20 28 [(_ x). ;; (
aed0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
aee0: 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ort (current-err
aef0: 6f 72 2d 70 6f 72 74 29 0a 20 20 20 20 20 20 20 or-port).
af00: 28 70 72 69 6e 74 66 20 22 7e 61 20 69 73 3a 20 (printf "~a is:
af10: 7e 61 5c 6e 22 20 27 78 20 28 77 69 74 68 2d 6f ~a\n" 'x (with-o
af20: 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 utput-to-string
af30: 28 6c 61 6d 62 64 61 20 28 29 20 28 42 42 70 70 (lambda () (BBpp
af40: 20 78 29 29 29 29 0a 20 20 20 20 20 3b 3b 20 20 x)))). ;;
af50: 29 0a 20 20 20 20 20 5d 0a 20 20 20 20 5b 28 5f ). ]. [(_
af60: 20 78 20 79 20 2e 2e 2e 29 20 28 62 65 67 69 6e x y ...) (begin
af70: 20 28 69 6e 73 70 65 63 74 20 78 29 20 28 69 6e (inspect x) (in
af80: 73 70 65 63 74 20 79 20 2e 2e 2e 29 29 5d 29 29 spect y ...))]))
af90: 0a 0a 0a 3b 3b 20 69 66 20 61 20 76 61 6c 75 65 ...;; if a value
afa0: 20 69 73 20 70 72 69 6e 74 61 62 6c 65 20 28 69 is printable (i
afb0: 2e 65 2e 20 73 74 72 69 6e 67 20 6f 72 20 6e 75 .e. string or nu
afc0: 6d 62 65 72 29 20 72 65 74 75 72 6e 20 74 68 65 mber) return the
afd0: 20 76 61 6c 75 65 0a 3b 3b 20 65 6c 73 65 20 72 value.;; else r
afe0: 65 74 75 72 6e 20 61 6e 20 65 6d 70 74 79 20 73 eturn an empty s
aff0: 74 72 69 6e 67 0a 28 64 65 66 69 6e 65 2d 69 6e tring.(define-in
b000: 6c 69 6e 65 20 28 70 72 69 6e 74 61 62 6c 65 20 line (printable
b010: 76 61 6c 29 0a 20 20 28 69 66 20 28 6f 72 20 28 val). (if (or (
b020: 6e 75 6d 62 65 72 3f 20 76 61 6c 29 28 73 74 72 number? val)(str
b030: 69 6e 67 3f 20 76 61 6c 29 29 20 76 61 6c 20 22 ing? val)) val "
b040: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f "))..(define (co
b050: 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 70 61 mmon:get-area-pa
b060: 74 68 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 th-signature).
b070: 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d (message-digest-
b080: 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d string (md5-prim
b090: 69 74 69 76 65 29 20 2a 74 6f 70 70 61 74 68 2a itive) *toppath*
b0a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
b0b0: 6d 6f 6e 3a 67 65 74 2d 73 69 67 6e 61 74 75 72 mon:get-signatur
b0c0: 65 20 73 74 72 29 0a 20 20 28 6d 65 73 73 61 67 e str). (messag
b0d0: 65 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 e-digest-string
b0e0: 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 (md5-primitive)
b0f0: 73 74 72 29 29 0a 0a 29 0a str))..).