Artifact
9b8dfbfc6d28d7d32ab3007a88b30fae207aa054:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 ==========..;; (
01e0: 75 73 65 20 74 72 61 63 65 29 0a 0a 28 69 6e 63 use trace)..(inc
01f0: 6c 75 64 65 20 22 61 6c 74 64 62 2e 73 63 6d 22 lude "altdb.scm"
0200: 29 0a 0a 3b 3b 20 53 6f 6d 65 20 6f 66 20 74 68 )..;; Some of th
0210: 65 73 65 20 72 6f 75 74 69 6e 65 73 20 75 73 65 ese routines use
0220: 3a 0a 3b 3b 0a 3b 3b 20 20 20 20 20 68 74 74 70 :.;;.;; http
0230: 3a 2f 2f 77 77 77 2e 63 73 2e 74 6f 72 6f 6e 74 ://www.cs.toront
0240: 6f 2e 65 64 75 2f 7e 67 66 62 2f 73 63 68 65 6d o.edu/~gfb/schem
0250: 65 2f 73 69 6d 70 6c 65 2d 6d 61 63 72 6f 73 2e e/simple-macros.
0260: 68 74 6d 6c 0a 3b 3b 0a 3b 3b 20 53 79 6e 74 61 html.;;.;; Synta
0270: 78 20 66 6f 72 20 64 65 66 69 6e 69 6e 67 20 6d x for defining m
0280: 61 63 72 6f 73 20 69 6e 20 61 20 73 69 6d 70 6c acros in a simpl
0290: 65 20 73 74 79 6c 65 20 73 69 6d 69 6c 61 72 20 e style similar
02a0: 74 6f 20 66 75 6e 63 74 69 6f 6e 20 64 65 66 69 to function defi
02b0: 6e 69 74 6f 6e 2c 0a 3b 3b 20 20 77 68 65 6e 20 niton,.;; when
02c0: 74 68 65 72 65 20 69 73 20 61 20 73 69 6e 67 6c there is a singl
02d0: 65 20 70 61 74 74 65 72 6e 20 66 6f 72 20 74 68 e pattern for th
02e0: 65 20 61 72 67 75 6d 65 6e 74 20 6c 69 73 74 20 e argument list
02f0: 61 6e 64 20 74 68 65 72 65 20 61 72 65 20 6e 6f and there are no
0300: 20 6b 65 79 77 6f 72 64 73 2e 0a 3b 3b 0a 3b 3b keywords..;;.;;
0310: 20 28 64 65 66 69 6e 65 2d 73 69 6d 70 6c 65 2d (define-simple-
0320: 73 79 6e 74 61 78 20 28 6e 61 6d 65 20 61 72 67 syntax (name arg
0330: 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e 29 0a ...) body ...).
0340: 3b 3b 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ;;..(define-synt
0350: 61 78 20 64 65 66 69 6e 65 2d 73 69 6d 70 6c 65 ax define-simple
0360: 2d 73 79 6e 74 61 78 0a 20 20 28 73 79 6e 74 61 -syntax. (synta
0370: 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 x-rules (). (
0380: 28 5f 20 28 6e 61 6d 65 20 61 72 67 20 2e 2e 2e (_ (name arg ...
0390: 29 20 62 6f 64 79 20 2e 2e 2e 29 0a 20 20 20 20 ) body ...).
03a0: 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 (define-syntax
03b0: 6e 61 6d 65 20 28 73 79 6e 74 61 78 2d 72 75 6c name (syntax-rul
03c0: 65 73 20 28 29 20 28 28 6e 61 6d 65 20 61 72 67 es () ((name arg
03d0: 20 2e 2e 2e 29 20 28 62 65 67 69 6e 20 62 6f 64 ...) (begin bod
03e0: 79 20 2e 2e 2e 29 29 29 29 29 29 29 0a 0a 28 64 y ...)))))))..(d
03f0: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 63 6f 6d efine-syntax com
0400: 6d 6f 6e 3a 68 61 6e 64 6c 65 2d 65 78 63 65 70 mon:handle-excep
0410: 74 69 6f 6e 73 0a 20 20 28 73 79 6e 74 61 78 2d tions. (syntax-
0420: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 5f rules (). ((_
0430: 20 65 78 6e 2d 69 6e 20 65 72 72 73 74 6d 74 20 exn-in errstmt
0440: 2e 2e 2e 29 28 68 61 6e 64 6c 65 2d 65 78 63 65 ...)(handle-exce
0450: 70 74 69 6f 6e 73 20 65 78 6e 2d 69 6e 20 65 72 ptions exn-in er
0460: 72 73 74 6d 74 20 2e 2e 2e 29 29 29 29 0a 0a 3b rstmt ...))))..;
0470: 3b 20 69 75 70 20 63 61 6c 6c 62 61 63 6b 73 20 ; iup callbacks
0480: 61 72 65 20 6e 6f 74 20 64 75 6d 70 69 6e 67 20 are not dumping
0490: 74 68 65 20 73 74 61 63 6b 2c 20 74 68 69 73 20 the stack, this
04a0: 69 73 20 61 20 77 6f 72 6b 2d 61 72 6f 75 6e 64 is a work-around
04b0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 2d 73 69 6d 70 .;;.(define-simp
04c0: 6c 65 2d 73 79 6e 74 61 78 20 28 64 65 62 75 67 le-syntax (debug
04d0: 3a 63 61 74 63 68 2d 61 6e 64 2d 64 75 6d 70 20 :catch-and-dump
04e0: 70 72 6f 63 20 70 72 6f 63 6e 61 6d 65 29 0a 20 proc procname).
04f0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
0500: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 ons. exn. (b
0510: 65 67 69 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 egin. (print
0520: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
0530: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
0540: 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 ). (with-out
0550: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 put-to-port (cur
0560: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
0570: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
0580: 28 29 0a 09 20 28 70 72 69 6e 74 20 28 28 63 6f ().. (print ((co
0590: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
05a0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
05b0: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 message) exn))..
05c0: 20 28 70 72 69 6e 74 20 22 43 61 6c 6c 62 61 63 (print "Callbac
05d0: 6b 20 65 72 72 6f 72 20 69 6e 20 22 20 70 72 6f k error in " pro
05e0: 63 6e 61 6d 65 29 0a 09 20 28 70 72 69 6e 74 20 cname).. (print
05f0: 22 46 75 6c 6c 20 63 6f 6e 64 69 74 69 6f 6e 20 "Full condition
0600: 69 6e 66 6f 3a 5c 6e 22 20 28 63 6f 6e 64 69 74 info:\n" (condit
0610: 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 29 ion->list exn)))
0620: 29 29 0a 20 20 20 28 70 72 6f 63 29 29 29 0a 0a )). (proc)))..
0630: 3b 3b 20 74 68 69 73 20 77 61 73 20 63 61 63 68 ;; this was cach
0640: 65 64 20 62 61 73 65 64 20 6f 6e 20 72 65 73 75 ed based on resu
0650: 6c 74 73 20 66 72 6f 6d 20 70 72 6f 66 69 6c 69 lts from profili
0660: 6e 67 20 62 75 74 20 69 74 20 74 75 72 6e 65 64 ng but it turned
0670: 20 6f 75 74 20 74 68 65 20 70 72 6f 66 69 6c 69 out the profili
0680: 6e 67 0a 3b 3b 20 73 6f 6d 65 68 6f 77 20 77 65 ng.;; somehow we
0690: 6e 74 20 77 72 6f 6e 67 20 2d 20 70 65 72 68 61 nt wrong - perha
06a0: 70 73 20 74 6f 6f 20 6d 61 6e 79 20 70 72 6f 63 ps too many proc
06b0: 65 73 73 65 73 20 77 72 69 74 69 6e 67 20 74 6f esses writing to
06c0: 20 69 74 2e 20 4c 65 61 76 69 6e 67 20 74 68 65 it. Leaving the
06d0: 20 63 61 63 68 69 6e 67 0a 3b 3b 20 69 6e 20 66 caching.;; in f
06e0: 6f 72 20 6e 6f 77 20 62 75 74 20 63 61 6e 20 70 or now but can p
06f0: 72 6f 62 61 62 6c 79 20 74 61 6b 65 20 69 74 20 robably take it
0700: 6f 75 74 20 6c 61 74 65 72 2e 0a 3b 3b 0a 28 64 out later..;;.(d
0710: 65 66 69 6e 65 20 28 64 65 62 75 67 3a 63 61 6c efine (debug:cal
0720: 63 2d 76 65 72 62 6f 73 69 74 79 20 76 73 74 72 c-verbosity vstr
0730: 29 0a 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 ). (or (hash-ta
0740: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0750: 2a 76 65 72 62 6f 73 69 74 79 2d 63 61 63 68 65 *verbosity-cache
0760: 2a 20 76 73 74 72 20 23 66 29 0a 20 20 20 20 20 * vstr #f).
0770: 20 28 6c 65 74 20 28 28 72 65 73 20 28 63 6f 6e (let ((res (con
0780: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
0790: 20 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 73 ((number? vs
07a0: 74 72 29 20 76 73 74 72 29 0a 20 20 20 20 20 20 tr) vstr).
07b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f ((no
07c0: 74 20 28 73 74 72 69 6e 67 3f 20 20 76 73 74 72 t (string? vstr
07d0: 29 29 20 20 20 31 29 0a 20 20 20 20 20 20 20 20 )) 1).
07e0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 28 73 ;; ((s
07f0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 20 22 5e 5c tring-match "^\
0800: 5c 73 2a 24 22 20 76 73 74 72 29 20 31 29 0a 20 \s*$" vstr) 1).
0810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0820: 20 28 76 73 74 72 20 20 20 20 20 20 20 20 20 20 (vstr
0830: 20 28 6c 65 74 20 28 28 64 65 62 75 67 76 61 6c (let ((debugval
0840: 73 20 20 28 66 69 6c 74 65 72 20 6e 75 6d 62 65 s (filter numbe
0850: 72 3f 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e r? (map string->
0860: 6e 75 6d 62 65 72 20 28 73 74 72 69 6e 67 2d 73 number (string-s
0870: 70 6c 69 74 20 76 73 74 72 20 22 2c 22 29 29 29 plit vstr ",")))
0880: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
08a0: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
08b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
08c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
08d0: 20 20 28 28 3e 20 28 6c 65 6e 67 74 68 20 64 65 ((> (length de
08e0: 62 75 67 76 61 6c 73 29 20 31 29 20 64 65 62 75 bugvals) 1) debu
08f0: 67 76 61 6c 73 29 0a 20 20 20 20 20 20 20 20 20 gvals).
0900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0910: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 3e 20 ((>
0920: 28 6c 65 6e 67 74 68 20 64 65 62 75 67 76 61 6c (length debugval
0930: 73 29 20 30 29 28 63 61 72 20 64 65 62 75 67 76 s) 0)(car debugv
0940: 61 6c 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 als)).
0950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0960: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
0970: 20 31 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 1)))).
0980: 20 20 20 20 20 20 20 20 20 28 28 61 72 67 73 3a ((args:
0990: 67 65 74 2d 61 72 67 20 22 2d 76 22 29 20 20 20 get-arg "-v")
09a0: 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 2).
09b0: 20 20 20 20 20 28 28 61 72 67 73 3a 67 65 74 2d ((args:get-
09c0: 61 72 67 20 22 2d 71 22 29 20 20 20 20 30 29 0a arg "-q") 0).
09d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09e0: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
09f0: 20 20 20 20 20 20 20 20 20 20 31 29 29 29 29 0a 1)))).
0a00: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
0a10: 62 6c 65 2d 73 65 74 21 20 2a 76 65 72 62 6f 73 ble-set! *verbos
0a20: 69 74 79 2d 63 61 63 68 65 2a 20 76 73 74 72 20 ity-cache* vstr
0a30: 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 65 73 res). res
0a40: 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 76 65 )))..;; check ve
0a50: 72 62 6f 73 69 74 79 2c 20 23 74 20 69 73 20 6f rbosity, #t is o
0a60: 6b 0a 28 64 65 66 69 6e 65 20 28 64 65 62 75 67 k.(define (debug
0a70: 3a 63 68 65 63 6b 2d 76 65 72 62 6f 73 69 74 79 :check-verbosity
0a80: 20 76 65 72 62 6f 73 69 74 79 20 76 73 74 72 29 verbosity vstr)
0a90: 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 6f 72 20 . (if (not (or
0aa0: 28 6e 75 6d 62 65 72 3f 20 76 65 72 62 6f 73 69 (number? verbosi
0ab0: 74 79 29 0a 09 20 20 20 20 20 20 20 28 6c 69 73 ty).. (lis
0ac0: 74 3f 20 20 20 76 65 72 62 6f 73 69 74 79 29 29 t? verbosity))
0ad0: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ). (begin..
0ae0: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 49 (print "ERROR: I
0af0: 6e 76 61 6c 69 64 20 64 65 62 75 67 20 76 61 6c nvalid debug val
0b00: 75 65 20 5c 22 22 20 76 73 74 72 20 22 5c 22 22 ue \"" vstr "\""
0b10: 29 0a 09 23 66 29 0a 20 20 20 20 20 20 23 74 29 )..#f). #t)
0b20: 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 62 75 )..(define (debu
0b30: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 6e 29 0a g:debug-mode n).
0b40: 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 61 6e 64 (cond. ((and
0b50: 20 28 6e 75 6d 62 65 72 3f 20 2a 76 65 72 62 6f (number? *verbo
0b60: 73 69 74 79 2a 29 20 20 20 3b 3b 20 6e 75 6d 62 sity*) ;; numb
0b70: 65 72 20 6e 75 6d 62 65 72 0a 09 20 28 6e 75 6d er number.. (num
0b80: 62 65 72 3f 20 6e 29 29 0a 20 20 20 20 28 3c 3d ber? n)). (<=
0b90: 20 6e 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 29 n *verbosity*))
0ba0: 0a 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f . ((and (list?
0bb0: 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 20 20 *verbosity*)
0bc0: 20 20 3b 3b 20 6c 69 73 74 20 20 20 6e 75 6d 62 ;; list numb
0bd0: 65 72 0a 09 20 28 6e 75 6d 62 65 72 3f 20 6e 29 er.. (number? n)
0be0: 29 0a 20 20 20 20 28 6d 65 6d 62 65 72 20 6e 20 ). (member n
0bf0: 2a 76 65 72 62 6f 73 69 74 79 2a 29 29 0a 20 20 *verbosity*)).
0c00: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 2a 76 ((and (list? *v
0c10: 65 72 62 6f 73 69 74 79 2a 29 20 20 20 20 20 3b erbosity*) ;
0c20: 3b 20 6c 69 73 74 20 20 20 6c 69 73 74 0a 09 20 ; list list..
0c30: 28 6c 69 73 74 3f 20 6e 29 29 0a 20 20 20 20 28 (list? n)). (
0c40: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 6c 73 65 74 not (null? (lset
0c50: 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 65 -intersection! e
0c60: 71 3f 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 6e q? *verbosity* n
0c70: 29 29 29 29 0a 20 20 20 28 28 61 6e 64 20 28 6e )))). ((and (n
0c80: 75 6d 62 65 72 3f 20 2a 76 65 72 62 6f 73 69 74 umber? *verbosit
0c90: 79 2a 29 0a 09 20 28 6c 69 73 74 3f 20 6e 29 29 y*).. (list? n))
0ca0: 0a 20 20 20 20 28 6d 65 6d 62 65 72 20 2a 76 65 . (member *ve
0cb0: 72 62 6f 73 69 74 79 2a 20 6e 29 29 29 29 0a 20 rbosity* n)))).
0cc0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 64 .(define (d
0cd0: 65 62 75 67 3a 73 65 74 75 70 29 0a 20 20 28 6c ebug:setup). (l
0ce0: 65 74 20 28 28 64 65 62 75 67 73 74 72 20 28 6f et ((debugstr (o
0cf0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
0d00: 22 2d 64 65 62 75 67 22 29 0a 09 09 20 20 20 20 "-debug")...
0d10: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 44 45 (getenv "MT_DE
0d20: 42 55 47 5f 4d 4f 44 45 22 29 29 29 29 0a 20 20 BUG_MODE")))).
0d30: 20 20 28 73 65 74 21 20 2a 76 65 72 62 6f 73 69 (set! *verbosi
0d40: 74 79 2a 20 28 64 65 62 75 67 3a 63 61 6c 63 2d ty* (debug:calc-
0d50: 76 65 72 62 6f 73 69 74 79 20 64 65 62 75 67 73 verbosity debugs
0d60: 74 72 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a tr)). (debug:
0d70: 63 68 65 63 6b 2d 76 65 72 62 6f 73 69 74 79 20 check-verbosity
0d80: 2a 76 65 72 62 6f 73 69 74 79 2a 20 64 65 62 75 *verbosity* debu
0d90: 67 73 74 72 29 0a 20 20 20 20 3b 3b 20 69 66 20 gstr). ;; if
0da0: 77 65 20 77 65 72 65 20 68 61 6e 64 65 64 20 61 we were handed a
0db0: 20 62 61 64 20 76 65 72 62 6f 73 69 74 79 20 72 bad verbosity r
0dc0: 75 6c 65 20 74 68 65 6e 20 77 65 20 77 69 6c 6c ule then we will
0dd0: 20 6f 76 65 72 72 69 64 65 20 69 74 20 77 69 74 override it wit
0de0: 68 20 31 20 61 6e 64 20 63 6f 6e 74 69 6e 75 65 h 1 and continue
0df0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 76 . (if (not *v
0e00: 65 72 62 6f 73 69 74 79 2a 29 28 73 65 74 21 20 erbosity*)(set!
0e10: 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 29 0a *verbosity* 1)).
0e20: 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 67 (if (or (arg
0e30: 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 65 62 75 s:get-arg "-debu
0e40: 67 22 29 0a 09 20 20 20 20 28 6e 6f 74 20 28 67 g").. (not (g
0e50: 65 74 65 6e 76 20 22 4d 54 5f 44 45 42 55 47 5f etenv "MT_DEBUG_
0e60: 4d 4f 44 45 22 29 29 29 0a 09 28 73 65 74 65 6e MODE")))..(seten
0e70: 76 20 22 4d 54 5f 44 45 42 55 47 5f 4d 4f 44 45 v "MT_DEBUG_MODE
0e80: 22 20 28 69 66 20 28 6c 69 73 74 3f 20 2a 76 65 " (if (list? *ve
0e90: 72 62 6f 73 69 74 79 2a 29 0a 09 09 09 09 20 20 rbosity*).....
0ea0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
0eb0: 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 perse (map conc
0ec0: 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 22 2c 22 *verbosity*) ","
0ed0: 29 0a 09 09 09 09 20 20 20 20 28 63 6f 6e 63 20 )..... (conc
0ee0: 2a 76 65 72 62 6f 73 69 74 79 2a 29 29 29 29 29 *verbosity*)))))
0ef0: 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 64 65 ). .(define (de
0f00: 62 75 67 3a 70 72 69 6e 74 20 6e 20 65 20 2e 20 bug:print n e .
0f10: 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 64 params). (if (d
0f20: 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 ebug:debug-mode
0f30: 6e 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f n). (with-o
0f40: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 6f utput-to-port (o
0f50: 72 20 65 20 28 63 75 72 72 65 6e 74 2d 65 72 72 r e (current-err
0f60: 6f 72 2d 70 6f 72 74 29 29 0a 09 28 6c 61 6d 62 or-port))..(lamb
0f70: 64 61 20 28 29 0a 09 20 20 28 69 66 20 2a 6c 6f da ().. (if *lo
0f80: 67 67 69 6e 67 2a 0a 09 20 20 20 20 20 20 28 64 gging*.. (d
0f90: 62 3a 6c 6f 67 2d 65 76 65 6e 74 20 28 61 70 70 b:log-event (app
0fa0: 6c 79 20 63 6f 6e 63 20 70 61 72 61 6d 73 29 29 ly conc params))
0fb0: 0a 09 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 .. (apply p
0fc0: 72 69 6e 74 20 70 61 72 61 6d 73 29 0a 09 20 20 rint params)..
0fd0: 20 20 20 20 29 29 29 29 29 0a 0a 3b 3b 20 42 72 )))))..;; Br
0fe0: 61 6e 64 6f 6e 27 73 20 64 65 62 75 67 20 70 72 andon's debug pr
0ff0: 69 6e 74 65 72 20 73 68 6f 72 74 63 75 74 20 28 inter shortcut (
1000: 69 6e 64 75 6c 67 65 20 6d 65 20 3a 29 0a 28 64 indulge me :).(d
1010: 65 66 69 6e 65 20 28 42 42 3e 20 2e 20 69 6e 2d efine (BB> . in-
1020: 61 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 args). (let* ((
1030: 73 74 61 63 6b 20 28 67 65 74 2d 63 61 6c 6c 2d stack (get-call-
1040: 63 68 61 69 6e 29 29 0a 20 20 20 20 20 20 20 20 chain)).
1050: 20 28 6c 6f 63 61 74 69 6f 6e 20 23 66 29 29 0a (location #f)).
1060: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
1070: 20 20 20 28 6c 61 6d 62 64 61 20 28 66 72 61 6d (lambda (fram
1080: 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 e). (let*
1090: 28 28 74 68 69 73 2d 6c 6f 63 20 28 76 65 63 74 ((this-loc (vect
10a0: 6f 72 2d 72 65 66 20 66 72 61 6d 65 20 30 29 29 or-ref frame 0))
10b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
10c0: 74 68 69 73 2d 66 75 6e 63 20 28 63 61 64 72 20 this-func (cadr
10d0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 68 (string-split th
10e0: 69 73 2d 6c 6f 63 20 22 20 22 29 29 29 29 0a 20 is-loc " ")))).
10f0: 20 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 (if (equ
1100: 61 6c 3f 20 74 68 69 73 2d 66 75 6e 63 20 22 42 al? this-func "B
1110: 42 3e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 B>").
1120: 20 20 28 73 65 74 21 20 6c 6f 63 61 74 69 6f 6e (set! location
1130: 20 74 68 69 73 2d 6c 6f 63 29 29 29 29 0a 20 20 this-loc)))).
1140: 20 20 20 73 74 61 63 6b 29 0a 20 20 20 20 28 6c stack). (l
1150: 65 74 20 28 28 64 70 2d 61 72 67 73 20 28 61 70 et ((dp-args (ap
1160: 70 65 6e 64 20 28 6c 69 73 74 20 30 20 2a 64 65 pend (list 0 *de
1170: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1180: 6c 6f 63 61 74 69 6f 6e 22 20 20 20 22 20 20 29 location" " )
1190: 20 69 6e 2d 61 72 67 73 29 29 29 0a 20 20 20 20 in-args))).
11a0: 20 20 28 61 70 70 6c 79 20 64 65 62 75 67 3a 70 (apply debug:p
11b0: 72 69 6e 74 20 64 70 2d 61 72 67 73 29 29 29 29 rint dp-args))))
11c0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 62 75 67 ..(define (debug
11d0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 6e 20 65 :print-error n e
11e0: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 . params). ;;
11f0: 6e 6f 72 6d 61 6c 20 70 72 69 6e 74 0a 20 20 28 normal print. (
1200: 69 66 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d if (debug:debug-
1210: 6d 6f 64 65 20 6e 29 0a 20 20 20 20 20 20 28 77 mode n). (w
1220: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
1230: 72 74 20 28 6f 72 20 65 20 28 63 75 72 72 65 6e rt (or e (curren
1240: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 t-error-port))..
1250: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 69 (lambda ().. (i
1260: 66 20 2a 6c 6f 67 67 69 6e 67 2a 0a 09 20 20 20 f *logging*..
1270: 20 20 20 28 64 62 3a 6c 6f 67 2d 65 76 65 6e 74 (db:log-event
1280: 20 28 61 70 70 6c 79 20 63 6f 6e 63 20 70 61 72 (apply conc par
1290: 61 6d 73 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 ams)).. ;;
12a0: 28 61 70 70 6c 79 20 70 72 69 6e 74 20 22 70 69 (apply print "pi
12b0: 64 3a 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f d:" (current-pro
12c0: 63 65 73 73 2d 69 64 29 20 22 20 22 20 70 61 72 cess-id) " " par
12d0: 61 6d 73 29 0a 09 20 20 20 20 20 20 28 61 70 70 ams).. (app
12e0: 6c 79 20 70 72 69 6e 74 20 22 45 52 52 4f 52 3a ly print "ERROR:
12f0: 20 22 20 70 61 72 61 6d 73 29 0a 09 20 20 20 20 " params)..
1300: 20 20 29 29 29 29 0a 20 20 3b 3b 20 70 61 73 73 )))). ;; pass
1310: 20 69 6d 70 6f 72 74 61 6e 74 20 6d 65 73 73 61 important messa
1320: 67 65 73 20 74 6f 20 73 74 64 65 72 72 0a 20 20 ges to stderr.
1330: 28 69 66 20 28 61 6e 64 20 28 65 71 3f 20 6e 20 (if (and (eq? n
1340: 30 29 28 6e 6f 74 20 28 65 71 3f 20 65 20 28 63 0)(not (eq? e (c
1350: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
1360: 74 29 29 29 29 20 0a 20 20 20 20 20 20 28 77 69 t)))) . (wi
1370: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
1380: 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 t (current-error
1390: 2d 70 6f 72 74 29 0a 09 28 6c 61 6d 62 64 61 20 -port)..(lambda
13a0: 28 29 0a 09 20 20 28 61 70 70 6c 79 20 70 72 69 ().. (apply pri
13b0: 6e 74 20 22 45 52 52 4f 52 3a 20 22 20 70 61 72 nt "ERROR: " par
13c0: 61 6d 73 29 0a 09 20 20 29 29 29 29 0a 0a 28 64 ams).. ))))..(d
13d0: 65 66 69 6e 65 20 28 64 65 62 75 67 3a 70 72 69 efine (debug:pri
13e0: 6e 74 2d 69 6e 66 6f 20 6e 20 65 20 2e 20 70 61 nt-info n e . pa
13f0: 72 61 6d 73 29 0a 20 20 28 69 66 20 28 64 65 62 rams). (if (deb
1400: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 6e 29 ug:debug-mode n)
1410: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 . (with-out
1420: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 6f 72 20 put-to-port (or
1430: 65 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 e (current-error
1440: 2d 70 6f 72 74 29 29 0a 09 28 6c 61 6d 62 64 61 -port))..(lambda
1450: 20 28 29 0a 09 20 20 28 69 66 20 2a 6c 6f 67 67 ().. (if *logg
1460: 69 6e 67 2a 0a 09 20 20 20 20 20 20 28 6c 65 74 ing*.. (let
1470: 20 28 28 72 65 73 20 28 66 6f 72 6d 61 74 23 66 ((res (format#f
1480: 6f 72 6d 61 74 20 23 66 20 22 49 4e 46 4f 3a 20 ormat #f "INFO:
1490: 28 7e 61 29 20 7e 61 22 20 6e 20 28 61 70 70 6c (~a) ~a" n (appl
14a0: 79 20 63 6f 6e 63 20 70 61 72 61 6d 73 29 29 29 y conc params)))
14b0: 29 0a 09 09 28 64 62 3a 6c 6f 67 2d 65 76 65 6e )...(db:log-even
14c0: 74 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 3b t res)).. ;
14d0: 3b 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 22 ; (apply print "
14e0: 70 69 64 3a 22 20 28 63 75 72 72 65 6e 74 2d 70 pid:" (current-p
14f0: 72 6f 63 65 73 73 2d 69 64 29 20 22 20 22 20 22 rocess-id) " " "
1500: 49 4e 46 4f 3a 20 28 22 20 6e 20 22 29 20 22 20 INFO: (" n ") "
1510: 70 61 72 61 6d 73 29 20 3b 3b 20 72 65 73 29 0a params) ;; res).
1520: 09 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 . (apply pr
1530: 69 6e 74 20 22 49 4e 46 4f 3a 20 28 22 20 6e 20 int "INFO: (" n
1540: 22 29 20 22 20 70 61 72 61 6d 73 29 20 3b 3b 20 ") " params) ;;
1550: 72 65 73 29 0a 09 20 20 20 20 20 20 29 29 29 29 res).. ))))
1560: 29 0a 0a 3b 3b 20 69 66 20 61 20 76 61 6c 75 65 )..;; if a value
1570: 20 69 73 20 70 72 69 6e 74 61 62 6c 65 20 28 69 is printable (i
1580: 2e 65 2e 20 73 74 72 69 6e 67 20 6f 72 20 6e 75 .e. string or nu
1590: 6d 62 65 72 29 20 72 65 74 75 72 6e 20 74 68 65 mber) return the
15a0: 20 76 61 6c 75 65 0a 3b 3b 20 65 6c 73 65 20 72 value.;; else r
15b0: 65 74 75 72 6e 20 61 6e 20 65 6d 70 74 79 20 73 eturn an empty s
15c0: 74 72 69 6e 67 0a 28 64 65 66 69 6e 65 2d 69 6e tring.(define-in
15d0: 6c 69 6e 65 20 28 70 72 69 6e 74 61 62 6c 65 20 line (printable
15e0: 76 61 6c 29 0a 20 20 28 69 66 20 28 6f 72 20 28 val). (if (or (
15f0: 6e 75 6d 62 65 72 3f 20 76 61 6c 29 28 73 74 72 number? val)(str
1600: 69 6e 67 3f 20 76 61 6c 29 29 20 76 61 6c 20 22 ing? val)) val "
1610: 22 29 29 0a 0a "))..