Artifact
4e8b115b3efbc0c39f6fccc0eaabe67c364c2e4b:
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 4e 65 65 64 20 61 20 6d 75 74 65 78 20 ;; Need a mutex
0640: 70 72 6f 74 65 63 74 65 64 20 77 61 79 20 74 6f protected way to
0650: 20 67 65 74 20 61 6e 64 20 73 65 74 20 76 61 6c get and set val
0660: 75 65 73 0a 3b 3b 20 6f 72 20 75 73 65 20 28 64 ues.;; or use (d
0670: 65 66 69 6e 65 2d 73 69 6d 70 6c 65 2d 73 79 6e efine-simple-syn
0680: 74 61 78 20 3f 3f 0a 3b 3b 0a 28 64 65 66 69 6e tax ??.;;.(defin
0690: 65 2d 69 6e 6c 69 6e 65 20 28 77 69 74 68 2d 6d e-inline (with-m
06a0: 75 74 65 78 20 6d 74 78 20 61 63 63 65 73 73 6f utex mtx accesso
06b0: 72 20 72 65 63 6f 72 64 20 2e 20 76 61 6c 29 0a r record . val).
06c0: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d (mutex-lock! m
06d0: 74 78 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 tx). (let ((res
06e0: 20 28 61 70 70 6c 79 20 61 63 63 65 73 73 6f 72 (apply accessor
06f0: 20 72 65 63 6f 72 64 20 76 61 6c 29 29 29 0a 20 record val))).
0700: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
0710: 21 20 6d 74 78 29 0a 20 20 20 20 72 65 73 29 29 ! mtx). res))
0720: 0a 0a 3b 3b 20 74 68 69 73 20 77 61 73 20 63 61 ..;; this was ca
0730: 63 68 65 64 20 62 61 73 65 64 20 6f 6e 20 72 65 ched based on re
0740: 73 75 6c 74 73 20 66 72 6f 6d 20 70 72 6f 66 69 sults from profi
0750: 6c 69 6e 67 20 62 75 74 20 69 74 20 74 75 72 6e ling but it turn
0760: 65 64 20 6f 75 74 20 74 68 65 20 70 72 6f 66 69 ed out the profi
0770: 6c 69 6e 67 0a 3b 3b 20 73 6f 6d 65 68 6f 77 20 ling.;; somehow
0780: 77 65 6e 74 20 77 72 6f 6e 67 20 2d 20 70 65 72 went wrong - per
0790: 68 61 70 73 20 74 6f 6f 20 6d 61 6e 79 20 70 72 haps too many pr
07a0: 6f 63 65 73 73 65 73 20 77 72 69 74 69 6e 67 20 ocesses writing
07b0: 74 6f 20 69 74 2e 20 4c 65 61 76 69 6e 67 20 74 to it. Leaving t
07c0: 68 65 20 63 61 63 68 69 6e 67 0a 3b 3b 20 69 6e he caching.;; in
07d0: 20 66 6f 72 20 6e 6f 77 20 62 75 74 20 63 61 6e for now but can
07e0: 20 70 72 6f 62 61 62 6c 79 20 74 61 6b 65 20 69 probably take i
07f0: 74 20 6f 75 74 20 6c 61 74 65 72 2e 0a 3b 3b 0a t out later..;;.
0800: 28 64 65 66 69 6e 65 20 28 64 65 62 75 67 3a 63 (define (debug:c
0810: 61 6c 63 2d 76 65 72 62 6f 73 69 74 79 20 76 73 alc-verbosity vs
0820: 74 72 29 0a 20 20 28 6f 72 20 28 68 61 73 68 2d tr). (or (hash-
0830: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0840: 74 20 2a 76 65 72 62 6f 73 69 74 79 2d 63 61 63 t *verbosity-cac
0850: 68 65 2a 20 76 73 74 72 20 23 66 29 0a 20 20 20 he* vstr #f).
0860: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 63 (let ((res (c
0870: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond.
0880: 20 20 20 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 ((number?
0890: 76 73 74 72 29 20 76 73 74 72 29 0a 20 20 20 20 vstr) vstr).
08a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
08b0: 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 20 76 73 not (string? vs
08c0: 74 72 29 29 20 20 20 31 29 0a 20 20 20 20 20 20 tr)) 1).
08d0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
08e0: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 20 22 (string-match "
08f0: 5e 5c 5c 73 2a 24 22 20 76 73 74 72 29 20 31 29 ^\\s*$" vstr) 1)
0900: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0910: 20 20 20 28 76 73 74 72 20 20 20 20 20 20 20 20 (vstr
0920: 20 20 20 28 6c 65 74 20 28 28 64 65 62 75 67 76 (let ((debugv
0930: 61 6c 73 20 20 28 66 69 6c 74 65 72 20 6e 75 6d als (filter num
0940: 62 65 72 3f 20 28 6d 61 70 20 73 74 72 69 6e 67 ber? (map string
0950: 2d 3e 6e 75 6d 62 65 72 20 28 73 74 72 69 6e 67 ->number (string
0960: 2d 73 70 6c 69 74 20 76 73 74 72 20 22 2c 22 29 -split vstr ",")
0970: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
0980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0990: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
09a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09c0: 20 20 20 20 28 28 3e 20 28 6c 65 6e 67 74 68 20 ((> (length
09d0: 64 65 62 75 67 76 61 6c 73 29 20 31 29 20 64 65 debugvals) 1) de
09e0: 62 75 67 76 61 6c 73 29 0a 20 20 20 20 20 20 20 bugvals).
09f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
0a10: 3e 20 28 6c 65 6e 67 74 68 20 64 65 62 75 67 76 > (length debugv
0a20: 61 6c 73 29 20 30 29 28 63 61 72 20 64 65 62 75 als) 0)(car debu
0a30: 67 76 61 6c 73 29 29 0a 20 20 20 20 20 20 20 20 gvals)).
0a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
0a60: 73 65 20 31 29 29 29 29 0a 20 20 20 20 20 20 20 se 1)))).
0a70: 20 20 20 20 20 20 20 20 20 20 20 28 28 61 72 67 ((arg
0a80: 73 3a 67 65 74 2d 61 72 67 20 22 2d 76 22 29 20 s:get-arg "-v")
0a90: 20 20 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 2).
0aa0: 20 20 20 20 20 20 20 28 28 61 72 67 73 3a 67 65 ((args:ge
0ab0: 74 2d 61 72 67 20 22 2d 71 22 29 20 20 20 20 30 t-arg "-q") 0
0ac0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0ad0: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
0ae0: 20 20 20 20 20 20 20 20 20 20 20 20 31 29 29 29 1)))
0af0: 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ). (hash-
0b00: 74 61 62 6c 65 2d 73 65 74 21 20 2a 76 65 72 62 table-set! *verb
0b10: 6f 73 69 74 79 2d 63 61 63 68 65 2a 20 76 73 74 osity-cache* vst
0b20: 72 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 r res). r
0b30: 65 73 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 es)))..;; check
0b40: 76 65 72 62 6f 73 69 74 79 2c 20 23 74 20 69 73 verbosity, #t is
0b50: 20 6f 6b 0a 28 64 65 66 69 6e 65 20 28 64 65 62 ok.(define (deb
0b60: 75 67 3a 63 68 65 63 6b 2d 76 65 72 62 6f 73 69 ug:check-verbosi
0b70: 74 79 20 76 65 72 62 6f 73 69 74 79 20 76 73 74 ty verbosity vst
0b80: 72 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 6f r). (if (not (o
0b90: 72 20 28 6e 75 6d 62 65 72 3f 20 76 65 72 62 6f r (number? verbo
0ba0: 73 69 74 79 29 0a 09 20 20 20 20 20 20 20 28 6c sity).. (l
0bb0: 69 73 74 3f 20 20 20 76 65 72 62 6f 73 69 74 79 ist? verbosity
0bc0: 29 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e ))). (begin
0bd0: 0a 09 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a ..(print "ERROR:
0be0: 20 49 6e 76 61 6c 69 64 20 64 65 62 75 67 20 76 Invalid debug v
0bf0: 61 6c 75 65 20 5c 22 22 20 76 73 74 72 20 22 5c alue \"" vstr "\
0c00: 22 22 29 0a 09 23 66 29 0a 20 20 20 20 20 20 23 "")..#f). #
0c10: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 t))..(define (de
0c20: 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 6e bug:debug-mode n
0c30: 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 61 ). (cond. ((a
0c40: 6e 64 20 28 6e 75 6d 62 65 72 3f 20 2a 76 65 72 nd (number? *ver
0c50: 62 6f 73 69 74 79 2a 29 20 20 20 3b 3b 20 6e 75 bosity*) ;; nu
0c60: 6d 62 65 72 20 6e 75 6d 62 65 72 0a 09 20 28 6e mber number.. (n
0c70: 75 6d 62 65 72 3f 20 6e 29 29 0a 20 20 20 20 28 umber? n)). (
0c80: 3c 3d 20 6e 20 2a 76 65 72 62 6f 73 69 74 79 2a <= n *verbosity*
0c90: 29 29 0a 20 20 20 28 28 61 6e 64 20 28 6c 69 73 )). ((and (lis
0ca0: 74 3f 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 t? *verbosity*)
0cb0: 20 20 20 20 3b 3b 20 6c 69 73 74 20 20 20 6e 75 ;; list nu
0cc0: 6d 62 65 72 0a 09 20 28 6e 75 6d 62 65 72 3f 20 mber.. (number?
0cd0: 6e 29 29 0a 20 20 20 20 28 6d 65 6d 62 65 72 20 n)). (member
0ce0: 6e 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 29 0a n *verbosity*)).
0cf0: 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 ((and (list?
0d00: 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 20 20 20 *verbosity*)
0d10: 20 3b 3b 20 6c 69 73 74 20 20 20 6c 69 73 74 0a ;; list list.
0d20: 09 20 28 6c 69 73 74 3f 20 6e 29 29 0a 20 20 20 . (list? n)).
0d30: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 6c 73 (not (null? (ls
0d40: 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 et-intersection!
0d50: 20 65 71 3f 20 2a 76 65 72 62 6f 73 69 74 79 2a eq? *verbosity*
0d60: 20 6e 29 29 29 29 0a 20 20 20 28 28 61 6e 64 20 n)))). ((and
0d70: 28 6e 75 6d 62 65 72 3f 20 2a 76 65 72 62 6f 73 (number? *verbos
0d80: 69 74 79 2a 29 0a 09 20 28 6c 69 73 74 3f 20 6e ity*).. (list? n
0d90: 29 29 0a 20 20 20 20 28 6d 65 6d 62 65 72 20 2a )). (member *
0da0: 76 65 72 62 6f 73 69 74 79 2a 20 6e 29 29 29 29 verbosity* n))))
0db0: 0a 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 . .(define
0dc0: 28 64 65 62 75 67 3a 73 65 74 75 70 29 0a 20 20 (debug:setup).
0dd0: 28 6c 65 74 20 28 28 64 65 62 75 67 73 74 72 20 (let ((debugstr
0de0: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
0df0: 67 20 22 2d 64 65 62 75 67 22 29 0a 09 09 20 20 g "-debug")...
0e00: 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (getenv "MT_
0e10: 44 45 42 55 47 5f 4d 4f 44 45 22 29 29 29 29 0a DEBUG_MODE")))).
0e20: 20 20 20 20 28 73 65 74 21 20 2a 76 65 72 62 6f (set! *verbo
0e30: 73 69 74 79 2a 20 28 64 65 62 75 67 3a 63 61 6c sity* (debug:cal
0e40: 63 2d 76 65 72 62 6f 73 69 74 79 20 64 65 62 75 c-verbosity debu
0e50: 67 73 74 72 29 29 0a 20 20 20 20 28 64 65 62 75 gstr)). (debu
0e60: 67 3a 63 68 65 63 6b 2d 76 65 72 62 6f 73 69 74 g:check-verbosit
0e70: 79 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 64 65 y *verbosity* de
0e80: 62 75 67 73 74 72 29 0a 20 20 20 20 3b 3b 20 69 bugstr). ;; i
0e90: 66 20 77 65 20 77 65 72 65 20 68 61 6e 64 65 64 f we were handed
0ea0: 20 61 20 62 61 64 20 76 65 72 62 6f 73 69 74 79 a bad verbosity
0eb0: 20 72 75 6c 65 20 74 68 65 6e 20 77 65 20 77 69 rule then we wi
0ec0: 6c 6c 20 6f 76 65 72 72 69 64 65 20 69 74 20 77 ll override it w
0ed0: 69 74 68 20 31 20 61 6e 64 20 63 6f 6e 74 69 6e ith 1 and contin
0ee0: 75 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ue. (if (not
0ef0: 2a 76 65 72 62 6f 73 69 74 79 2a 29 28 73 65 74 *verbosity*)(set
0f00: 21 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 ! *verbosity* 1)
0f10: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 ). (if (or (a
0f20: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 65 rgs:get-arg "-de
0f30: 62 75 67 22 29 0a 09 20 20 20 20 28 6e 6f 74 20 bug").. (not
0f40: 28 67 65 74 65 6e 76 20 22 4d 54 5f 44 45 42 55 (getenv "MT_DEBU
0f50: 47 5f 4d 4f 44 45 22 29 29 29 0a 09 28 73 65 74 G_MODE")))..(set
0f60: 65 6e 76 20 22 4d 54 5f 44 45 42 55 47 5f 4d 4f env "MT_DEBUG_MO
0f70: 44 45 22 20 28 69 66 20 28 6c 69 73 74 3f 20 2a DE" (if (list? *
0f80: 76 65 72 62 6f 73 69 74 79 2a 29 0a 09 09 09 09 verbosity*).....
0f90: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
0fa0: 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e rsperse (map con
0fb0: 63 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 20 22 c *verbosity*) "
0fc0: 2c 22 29 0a 09 09 09 09 20 20 20 20 28 63 6f 6e ,")..... (con
0fd0: 63 20 2a 76 65 72 62 6f 73 69 74 79 2a 29 29 29 c *verbosity*)))
0fe0: 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 ))). .(define (
0ff0: 64 65 62 75 67 3a 70 72 69 6e 74 20 6e 20 65 20 debug:print n e
1000: 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 . params). (if
1010: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
1020: 65 20 6e 29 0a 20 20 20 20 20 20 28 77 69 74 68 e n). (with
1030: 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 -output-to-port
1040: 28 6f 72 20 65 20 28 63 75 72 72 65 6e 74 2d 65 (or e (current-e
1050: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 28 6c 61 rror-port))..(la
1060: 6d 62 64 61 20 28 29 0a 09 20 20 28 69 66 20 2a mbda ().. (if *
1070: 6c 6f 67 67 69 6e 67 2a 0a 09 20 20 20 20 20 20 logging*..
1080: 28 64 62 3a 6c 6f 67 2d 65 76 65 6e 74 20 28 61 (db:log-event (a
1090: 70 70 6c 79 20 63 6f 6e 63 20 70 61 72 61 6d 73 pply conc params
10a0: 29 29 0a 09 20 20 20 20 20 20 28 61 70 70 6c 79 )).. (apply
10b0: 20 70 72 69 6e 74 20 70 61 72 61 6d 73 29 0a 09 print params)..
10c0: 20 20 20 20 20 20 29 29 29 29 29 0a 0a 3b 3b 20 )))))..;;
10d0: 42 72 61 6e 64 6f 6e 27 73 20 64 65 62 75 67 20 Brandon's debug
10e0: 70 72 69 6e 74 65 72 20 73 68 6f 72 74 63 75 74 printer shortcut
10f0: 20 28 69 6e 64 75 6c 67 65 20 6d 65 20 3a 29 0a (indulge me :).
1100: 28 64 65 66 69 6e 65 20 2a 42 42 2d 70 72 6f 63 (define *BB-proc
1110: 65 73 73 2d 73 74 61 72 74 74 69 6d 65 2a 20 28 ess-starttime* (
1120: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
1130: 6f 6e 64 73 29 29 0a 28 64 65 66 69 6e 65 20 28 onds)).(define (
1140: 42 42 3e 20 2e 20 69 6e 2d 61 72 67 73 29 0a 20 BB> . in-args).
1150: 20 28 6c 65 74 2a 20 28 28 73 74 61 63 6b 20 28 (let* ((stack (
1160: 67 65 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 get-call-chain))
1170: 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 63 61 74 . (locat
1180: 69 6f 6e 20 22 3f 3f 22 29 29 0a 20 20 20 20 28 ion "??")). (
1190: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
11a0: 61 6d 62 64 61 20 28 66 72 61 6d 65 29 0a 20 20 ambda (frame).
11b0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 69 (let* ((thi
11c0: 73 2d 6c 6f 63 20 28 76 65 63 74 6f 72 2d 72 65 s-loc (vector-re
11d0: 66 20 66 72 61 6d 65 20 30 29 29 0a 20 20 20 20 f frame 0)).
11e0: 20 20 20 20 20 20 20 20 20 20 28 74 65 6d 70 20 (temp
11f0: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 (string-spli
1200: 74 20 28 2d 3e 73 74 72 69 6e 67 20 74 68 69 73 t (->string this
1210: 2d 6c 6f 63 29 20 22 20 22 29 29 0a 20 20 20 20 -loc) " ")).
1220: 20 20 20 20 20 20 20 20 20 20 28 74 68 69 73 2d (this-
1230: 66 75 6e 63 20 28 69 66 20 28 61 6e 64 20 28 6c func (if (and (l
1240: 69 73 74 3f 20 74 65 6d 70 29 20 28 3e 20 28 6c ist? temp) (> (l
1250: 65 6e 67 74 68 20 74 65 6d 70 29 20 31 29 29 20 ength temp) 1))
1260: 28 63 61 64 72 20 74 65 6d 70 29 20 22 3f 3f 3f (cadr temp) "???
1270: 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 "))). (i
1280: 66 20 28 65 71 75 61 6c 3f 20 74 68 69 73 2d 66 f (equal? this-f
1290: 75 6e 63 20 22 42 42 3e 22 29 0a 20 20 20 20 20 unc "BB>").
12a0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 6f (set! lo
12b0: 63 61 74 69 6f 6e 20 74 68 69 73 2d 6c 6f 63 29 cation this-loc)
12c0: 29 29 29 0a 20 20 20 20 20 73 74 61 63 6b 29 0a ))). stack).
12d0: 20 20 20 20 28 6c 65 74 20 28 28 64 70 2d 61 72 (let ((dp-ar
12e0: 67 73 0a 20 20 20 20 20 20 20 20 20 20 20 28 61 gs. (a
12f0: 70 70 65 6e 64 0a 20 20 20 20 20 20 20 20 20 20 ppend.
1300: 20 20 28 6c 69 73 74 20 30 20 2a 64 65 66 61 75 (list 0 *defau
1310: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 20 20 20 lt-log-port*.
1320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1330: 63 6f 6e 63 20 6c 6f 63 61 74 69 6f 6e 20 22 40 conc location "@
1340: 22 28 2f 20 28 2d 20 28 63 75 72 72 65 6e 74 2d "(/ (- (current-
1350: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 2a 42 milliseconds) *B
1360: 42 2d 70 72 6f 63 65 73 73 2d 73 74 61 72 74 74 B-process-startt
1370: 69 6d 65 2a 29 20 31 30 30 30 29 22 20 20 20 22 ime*) 1000)" "
1380: 29 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 ) ).
1390: 20 69 6e 2d 61 72 67 73 29 29 29 0a 20 20 20 20 in-args))).
13a0: 20 20 28 61 70 70 6c 79 20 64 65 62 75 67 3a 70 (apply debug:p
13b0: 72 69 6e 74 20 64 70 2d 61 72 67 73 29 29 29 29 rint dp-args))))
13c0: 0a 0a 28 64 65 66 69 6e 65 20 2a 42 42 70 70 5f ..(define *BBpp_
13d0: 63 75 73 74 6f 6d 5f 65 78 70 61 6e 64 65 72 73 custom_expanders
13e0: 5f 6c 69 73 74 2a 20 28 6d 61 6b 65 2d 68 61 73 _list* (make-has
13f0: 68 2d 74 61 62 6c 65 29 29 0a 0a 0a 0a 3b 3b 20 h-table))....;;
1400: 72 65 67 69 73 74 65 72 20 68 61 73 68 20 74 61 register hash ta
1410: 62 6c 65 73 20 77 69 74 68 20 42 42 70 70 2e 0a bles with BBpp..
1420: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
1430: 20 2a 42 42 70 70 5f 63 75 73 74 6f 6d 5f 65 78 *BBpp_custom_ex
1440: 70 61 6e 64 65 72 73 5f 6c 69 73 74 2a 20 48 41 panders_list* HA
1450: 53 48 5f 54 41 42 4c 45 3a 0a 20 20 20 20 20 20 SH_TABLE:.
1460: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
1470: 20 68 61 73 68 2d 74 61 62 6c 65 3f 20 68 61 73 hash-table? has
1480: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 29 29 h-table->alist))
1490: 0a 0a 3b 3b 20 74 65 73 74 20 6e 61 6d 65 20 63 ..;; test name c
14a0: 6f 6e 76 65 72 74 65 72 0a 28 64 65 66 69 6e 65 onverter.(define
14b0: 20 28 42 42 70 70 5f 63 75 73 74 6f 6d 5f 63 6f (BBpp_custom_co
14c0: 6e 76 65 72 74 65 72 20 61 72 67 29 0a 20 20 28 nverter arg). (
14d0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 let ((res #f)).
14e0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
14f0: 20 20 28 6c 61 6d 62 64 61 20 28 63 75 73 74 6f (lambda (custo
1500: 6d 2d 74 79 70 65 2d 6e 61 6d 65 29 0a 20 20 20 m-type-name).
1510: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 73 74 (let* ((cust
1520: 6f 6d 2d 74 79 70 65 2d 69 6e 66 6f 20 20 20 20 om-type-info
1530: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
1540: 66 20 2a 42 42 70 70 5f 63 75 73 74 6f 6d 5f 65 f *BBpp_custom_e
1550: 78 70 61 6e 64 65 72 73 5f 6c 69 73 74 2a 20 63 xpanders_list* c
1560: 75 73 74 6f 6d 2d 74 79 70 65 2d 6e 61 6d 65 29 ustom-type-name)
1570: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1580: 28 63 75 73 74 6f 6d 2d 74 79 70 65 2d 74 65 73 (custom-type-tes
1590: 74 20 20 20 20 20 20 28 63 61 72 20 63 75 73 74 t (car cust
15a0: 6f 6d 2d 74 79 70 65 2d 69 6e 66 6f 29 29 0a 20 om-type-info)).
15b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 (cu
15c0: 73 74 6f 6d 2d 74 79 70 65 2d 63 6f 6e 76 65 72 stom-type-conver
15d0: 74 65 72 20 28 63 64 72 20 63 75 73 74 6f 6d 2d ter (cdr custom-
15e0: 74 79 70 65 2d 69 6e 66 6f 29 29 29 0a 20 20 20 type-info))).
15f0: 20 20 20 20 20 20 28 77 68 65 6e 20 28 61 6e 64 (when (and
1600: 20 28 6e 6f 74 20 72 65 73 29 20 28 63 75 73 74 (not res) (cust
1610: 6f 6d 2d 74 79 70 65 2d 74 65 73 74 20 61 72 67 om-type-test arg
1620: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 )). (s
1630: 65 74 21 20 72 65 73 20 28 63 75 73 74 6f 6d 2d et! res (custom-
1640: 74 79 70 65 2d 63 6f 6e 76 65 72 74 65 72 20 61 type-converter a
1650: 72 67 29 29 29 29 29 0a 20 20 20 20 20 28 68 61 rg))))). (ha
1660: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 42 sh-table-keys *B
1670: 42 70 70 5f 63 75 73 74 6f 6d 5f 65 78 70 61 6e Bpp_custom_expan
1680: 64 65 72 73 5f 6c 69 73 74 2a 29 29 0a 20 20 20 ders_list*)).
1690: 20 28 69 66 20 72 65 73 20 28 42 42 70 70 5f 20 (if res (BBpp_
16a0: 72 65 73 29 20 61 72 67 29 29 29 0a 0a 28 64 65 res) arg)))..(de
16b0: 66 69 6e 65 20 28 42 42 70 70 5f 20 61 72 67 29 fine (BBpp_ arg)
16c0: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 3b 3b 28 28 . (cond. ;;((
16d0: 53 4f 4d 45 53 54 52 55 43 54 3f 20 61 72 67 29 SOMESTRUCT? arg)
16e0: 20 28 63 6f 6e 73 20 53 4f 4d 45 53 54 52 55 43 (cons SOMESTRUC
16f0: 54 3a 20 28 53 4f 4d 45 53 54 52 55 43 54 2d 3e T: (SOMESTRUCT->
1700: 61 6c 69 73 74 20 61 72 67 29 29 29 0a 20 20 20 alist arg))).
1710: 3b 3b 28 28 64 62 6f 61 72 64 3a 74 61 62 64 61 ;;((dboard:tabda
1720: 74 3f 20 61 72 67 29 20 28 63 6f 6e 73 20 64 62 t? arg) (cons db
1730: 6f 61 72 64 3a 74 61 62 64 61 74 3a 20 28 64 62 oard:tabdat: (db
1740: 6f 61 72 64 3a 74 61 62 64 61 74 2d 3e 61 6c 69 oard:tabdat->ali
1750: 73 74 20 61 72 67 29 29 29 0a 20 20 20 28 28 68 st arg))). ((h
1760: 61 73 68 2d 74 61 62 6c 65 3f 20 61 72 67 29 0a ash-table? arg).
1770: 20 20 20 20 28 6c 65 74 20 28 28 61 6c 20 28 68 (let ((al (h
1780: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
1790: 20 61 72 67 29 29 29 0a 20 20 20 20 20 20 28 42 arg))). (B
17a0: 42 70 70 5f 20 28 63 6f 6e 73 20 48 41 53 48 5f Bpp_ (cons HASH_
17b0: 54 41 42 4c 45 3a 20 61 6c 29 29 29 29 0a 20 20 TABLE: al)))).
17c0: 20 28 28 6e 75 6c 6c 3f 20 61 72 67 29 20 27 28 ((null? arg) '(
17d0: 29 29 0a 20 20 20 3b 3b 28 28 6c 69 73 74 3f 20 )). ;;((list?
17e0: 61 72 67 29 20 28 63 6f 6e 73 20 28 42 42 70 70 arg) (cons (BBpp
17f0: 5f 20 28 63 61 72 20 61 72 67 29 29 20 28 42 42 _ (car arg)) (BB
1800: 70 70 5f 20 28 63 64 72 20 61 72 67 29 29 29 29 pp_ (cdr arg))))
1810: 0a 20 20 20 28 28 70 61 69 72 3f 20 61 72 67 29 . ((pair? arg)
1820: 20 28 63 6f 6e 73 20 28 42 42 70 70 5f 20 28 63 (cons (BBpp_ (c
1830: 61 72 20 61 72 67 29 29 20 28 42 42 70 70 5f 20 ar arg)) (BBpp_
1840: 28 63 64 72 20 61 72 67 29 29 29 29 0a 20 20 20 (cdr arg)))).
1850: 28 65 6c 73 65 20 28 42 42 70 70 5f 63 75 73 74 (else (BBpp_cust
1860: 6f 6d 5f 63 6f 6e 76 65 72 74 65 72 20 61 72 67 om_converter arg
1870: 29 29 29 29 0a 0a 3b 3b 20 42 72 61 6e 64 6f 6e ))))..;; Brandon
1880: 27 73 20 70 72 65 74 74 79 20 70 72 69 6e 74 65 's pretty printe
1890: 72 2e 20 20 49 74 20 65 78 70 61 6e 64 73 20 68 r. It expands h
18a0: 61 73 68 65 73 20 61 6e 64 20 63 75 73 74 6f 6d ashes and custom
18b0: 20 74 79 70 65 73 20 69 6e 20 61 64 64 69 74 69 types in additi
18c0: 6f 6e 20 74 6f 20 72 65 67 75 6c 61 72 20 70 70 on to regular pp
18d0: 0a 28 64 65 66 69 6e 65 20 28 42 42 70 70 20 61 .(define (BBpp a
18e0: 72 67 29 0a 20 20 28 70 70 20 28 42 42 70 70 5f rg). (pp (BBpp_
18f0: 20 61 72 67 29 29 29 0a 0a 3b 28 75 73 65 20 64 arg)))..;(use d
1900: 65 66 69 6e 65 2d 6d 61 63 72 6f 29 0a 28 64 65 efine-macro).(de
1910: 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 6e 73 70 fine-syntax insp
1920: 65 63 74 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 ect. (syntax-ru
1930: 6c 65 73 20 28 29 0a 20 20 20 20 5b 28 5f 20 78 les (). [(_ x
1940: 29 0a 20 20 20 20 3b 3b 20 28 77 69 74 68 2d 6f ). ;; (with-o
1950: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 63 utput-to-port (c
1960: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
1970: 74 29 0a 20 20 20 20 20 20 20 28 70 72 69 6e 74 t). (print
1980: 66 20 22 7e 61 20 69 73 3a 20 7e 61 5c 6e 22 20 f "~a is: ~a\n"
1990: 27 78 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 'x (with-output-
19a0: 74 6f 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 to-string (lambd
19b0: 61 20 28 29 20 28 42 42 70 70 20 78 29 29 29 29 a () (BBpp x))))
19c0: 0a 20 20 20 20 20 3b 3b 20 20 29 0a 20 20 20 20 . ;; ).
19d0: 20 5d 0a 20 20 20 20 5b 28 5f 20 78 20 79 20 2e ]. [(_ x y .
19e0: 2e 2e 29 20 28 62 65 67 69 6e 20 28 69 6e 73 70 ..) (begin (insp
19f0: 65 63 74 20 78 29 20 28 69 6e 73 70 65 63 74 20 ect x) (inspect
1a00: 79 20 2e 2e 2e 29 29 5d 29 29 0a 0a 28 64 65 66 y ...))]))..(def
1a10: 69 6e 65 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ine (debug:print
1a20: 2d 65 72 72 6f 72 20 6e 20 65 20 2e 20 70 61 72 -error n e . par
1a30: 61 6d 73 29 0a 20 20 3b 3b 20 6e 6f 72 6d 61 6c ams). ;; normal
1a40: 20 70 72 69 6e 74 0a 20 20 28 69 66 20 28 64 65 print. (if (de
1a50: 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 6e bug:debug-mode n
1a60: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 ). (with-ou
1a70: 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 6f 72 tput-to-port (or
1a80: 20 65 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f e (current-erro
1a90: 72 2d 70 6f 72 74 29 29 0a 09 28 6c 61 6d 62 64 r-port))..(lambd
1aa0: 61 20 28 29 0a 09 20 20 28 69 66 20 2a 6c 6f 67 a ().. (if *log
1ab0: 67 69 6e 67 2a 0a 09 20 20 20 20 20 20 28 64 62 ging*.. (db
1ac0: 3a 6c 6f 67 2d 65 76 65 6e 74 20 28 61 70 70 6c :log-event (appl
1ad0: 79 20 63 6f 6e 63 20 70 61 72 61 6d 73 29 29 0a y conc params)).
1ae0: 09 20 20 20 20 20 20 3b 3b 20 28 61 70 70 6c 79 . ;; (apply
1af0: 20 70 72 69 6e 74 20 22 70 69 64 3a 22 20 28 63 print "pid:" (c
1b00: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
1b10: 64 29 20 22 20 22 20 70 61 72 61 6d 73 29 0a 09 d) " " params)..
1b20: 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 (apply pri
1b30: 6e 74 20 22 45 52 52 4f 52 3a 20 22 20 70 61 72 nt "ERROR: " par
1b40: 61 6d 73 29 0a 09 20 20 20 20 20 20 29 29 29 29 ams).. ))))
1b50: 0a 20 20 3b 3b 20 70 61 73 73 20 69 6d 70 6f 72 . ;; pass impor
1b60: 74 61 6e 74 20 6d 65 73 73 61 67 65 73 20 74 6f tant messages to
1b70: 20 73 74 64 65 72 72 0a 20 20 28 69 66 20 28 61 stderr. (if (a
1b80: 6e 64 20 28 65 71 3f 20 6e 20 30 29 28 6e 6f 74 nd (eq? n 0)(not
1b90: 20 28 65 71 3f 20 65 20 28 63 75 72 72 65 6e 74 (eq? e (current
1ba0: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 29 20 -error-port))))
1bb0: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 . (with-out
1bc0: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 put-to-port (cur
1bd0: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
1be0: 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 ..(lambda ()..
1bf0: 28 61 70 70 6c 79 20 70 72 69 6e 74 20 22 45 52 (apply print "ER
1c00: 52 4f 52 3a 20 22 20 70 61 72 61 6d 73 29 0a 09 ROR: " params)..
1c10: 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))..(define
1c20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1c30: 6f 20 6e 20 65 20 2e 20 70 61 72 61 6d 73 29 0a o n e . params).
1c40: 20 20 28 69 66 20 28 64 65 62 75 67 3a 64 65 62 (if (debug:deb
1c50: 75 67 2d 6d 6f 64 65 20 6e 29 0a 20 20 20 20 20 ug-mode n).
1c60: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
1c70: 2d 70 6f 72 74 20 28 6f 72 20 65 20 28 63 75 72 -port (or e (cur
1c80: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
1c90: 29 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 )..(lambda ()..
1ca0: 20 28 69 66 20 2a 6c 6f 67 67 69 6e 67 2a 0a 09 (if *logging*..
1cb0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
1cc0: 20 28 66 6f 72 6d 61 74 23 66 6f 72 6d 61 74 20 (format#format
1cd0: 23 66 20 22 49 4e 46 4f 3a 20 28 7e 61 29 20 7e #f "INFO: (~a) ~
1ce0: 61 22 20 6e 20 28 61 70 70 6c 79 20 63 6f 6e 63 a" n (apply conc
1cf0: 20 70 61 72 61 6d 73 29 29 29 29 0a 09 09 28 64 params))))...(d
1d00: 62 3a 6c 6f 67 2d 65 76 65 6e 74 20 72 65 73 29 b:log-event res)
1d10: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 61 70 70 ).. ;; (app
1d20: 6c 79 20 70 72 69 6e 74 20 22 70 69 64 3a 22 20 ly print "pid:"
1d30: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
1d40: 2d 69 64 29 20 22 20 22 20 22 49 4e 46 4f 3a 20 -id) " " "INFO:
1d50: 28 22 20 6e 20 22 29 20 22 20 70 61 72 61 6d 73 (" n ") " params
1d60: 29 20 3b 3b 20 72 65 73 29 0a 09 20 20 20 20 20 ) ;; res)..
1d70: 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 22 49 (apply print "I
1d80: 4e 46 4f 3a 20 28 22 20 6e 20 22 29 20 22 20 70 NFO: (" n ") " p
1d90: 61 72 61 6d 73 29 20 3b 3b 20 72 65 73 29 0a 09 arams) ;; res)..
1da0: 20 20 20 20 20 20 29 29 29 29 29 0a 0a 3b 3b 20 )))))..;;
1db0: 69 66 20 61 20 76 61 6c 75 65 20 69 73 20 70 72 if a value is pr
1dc0: 69 6e 74 61 62 6c 65 20 28 69 2e 65 2e 20 73 74 intable (i.e. st
1dd0: 72 69 6e 67 20 6f 72 20 6e 75 6d 62 65 72 29 20 ring or number)
1de0: 72 65 74 75 72 6e 20 74 68 65 20 76 61 6c 75 65 return the value
1df0: 0a 3b 3b 20 65 6c 73 65 20 72 65 74 75 72 6e 20 .;; else return
1e00: 61 6e 20 65 6d 70 74 79 20 73 74 72 69 6e 67 0a an empty string.
1e10: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
1e20: 70 72 69 6e 74 61 62 6c 65 20 76 61 6c 29 0a 20 printable val).
1e30: 20 28 69 66 20 28 6f 72 20 28 6e 75 6d 62 65 72 (if (or (number
1e40: 3f 20 76 61 6c 29 28 73 74 72 69 6e 67 3f 20 76 ? val)(string? v
1e50: 61 6c 29 29 20 76 61 6c 20 22 22 29 29 0a 0a al)) val ""))..